file.lisp 2.5 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778
  1. (in-package :cl-user)
  2. (defpackage file
  3. (:use :cl)
  4. (:import-from :trivial-mimes
  5. :mime)
  6. (:import-from :local-time
  7. :format-rfc1123-timestring
  8. :universal-to-timestamp)
  9. (:import-from :uiop
  10. :file-exists-p
  11. :directory-exists-p)
  12. (:import-from :alexandria
  13. :starts-with-subseq)
  14. (:export :make-app))
  15. (in-package :file)
  16. (define-condition bad-request (simple-condition) ())
  17. (define-condition not-found (simple-condition) ())
  18. (defun make-app (&key file (root #P"./") (encoding "utf-8"))
  19. (lambda (env)
  20. (handler-case
  21. (serve-path
  22. (locate-file (or file
  23. ;; remove "/"
  24. (subseq (getf env :path-info) 1))
  25. root)
  26. encoding)
  27. (bad-request ()
  28. '(400 (:content-type "text/plain"
  29. :content-length 11)
  30. ("Bad Request")))
  31. (not-found ()
  32. '(404 (:content-type "text/plain"
  33. :content-length 9)
  34. ("Not Found"))))))
  35. (defun locate-file (path root)
  36. (print "path")
  37. (print path)
  38. (print "root")
  39. (print root)
  40. (when (find :up (pathname-directory path) :test #'eq)
  41. (error 'bad-request))
  42. (let ((file (merge-pathnames path root)))
  43. (cond
  44. ((position #\Null (namestring file))
  45. (error 'bad-request))
  46. ((not (and (ignore-errors
  47. ;; Ignore simple-file-error in a case that
  48. ;; the file path contains some special characters like "?".
  49. ;; See https://github.com/fukamachi/clack/issues/111
  50. (uiop:file-exists-p file))
  51. (not (uiop:directory-exists-p file))))
  52. (error 'not-found))
  53. (t file))))
  54. (defun serve-path (file encoding)
  55. (let ((content-type (or (mimes:mime-lookup file)
  56. "application/octet-stream"))
  57. (univ-time (or (file-write-date file)
  58. (get-universal-time))))
  59. (when (starts-with-subseq "text" content-type)
  60. (setf content-type
  61. (format nil "~A~:[~;~:*; charset=~A~]"
  62. content-type encoding)))
  63. (with-open-file (stream file
  64. :direction :input
  65. :if-does-not-exist nil)
  66. `(200
  67. (:content-type ,content-type
  68. :content-length ,(file-length stream)
  69. :last-modified
  70. ,(format-rfc1123-timestring nil
  71. (universal-to-timestamp univ-time)))
  72. ,file))))