share/share.rkt

#lang racket/base
(require racket/match
         web-server/servlet
         web-server/servlet-env
         web-server/formlets
         web-server/dispatch
         web-server/http
         racket/file
         threading
         xml)
(provide (all-defined-out))

(define (ensure-directory dir)
  (if (not (directory-exists? dir))
      (make-directory dir) null)
  dir)

(define (download-link f)
  `(a ((href ,(path->string f)))
              ,(path->string f)))

(define upload-dir
  (ensure-directory
    (build-path
      (find-system-path 'orig-dir)
      "uploads")))

(define (start request)
    (app-dispatch request))

(define-values (app-dispatch app-url)
  (dispatch-rules
    (("") share)))

(define (respond-unknown-file req)
  (response/xexpr
    #:code 404 #:message #"ERROR"
    `(html (body "Not found."))))

(define (share initial-req #:message (message ""))

  (define req
    (send/suspend
     (lambda (k-url)
       (response/xexpr
        `(html
           (body
             (title "File Sharing Server")
             (div ,message)
             (form ((action ,k-url)
                    (method "post")
                    (enctype "multipart/form-data"))
                   (h2 "Upload files:")
                   (input ((type "file")
                           (name "file")
                           (multiple "multiple")))
                   (br)
                   (input ((type "submit")
                           (value "Upload"))))
             (h2 "Shared files:")
             (ul ,@(map (λ (f) `(li ,(download-link f)))
                        (directory-list upload-dir)))))))))


  (define (save-files b)
    (current-directory upload-dir)
    (match b
      ((struct binding:file (field filename headers content))
       (if (> (bytes-length filename) 0)
         (begin
           (display-to-file content
                            (bytes->string/utf-8 filename)
                            #:exists 'replace)
           `(li ,(~> filename
                     bytes->string/utf-8
                     build-path
                     download-link)))
         "No files uploaded."))))

  (response/xexpr
    (share req #:message
   `(html (body
      (h3 "You uploaded:")
      (ul ,@(map save-files (request-bindings/raw req))))))))

(define (main)
  (serve/servlet start
    #:servlet-path "/"
    #:port 8080
    #:launch-browser? #f
    #:extra-files-paths (list (build-path "static")
                              (build-path "uploads"))
    #:file-not-found-responder respond-unknown-file
    #:server-root-path (current-directory)))