Flexible Lisp Blogware. Fork for personal use. Mirrored from https://github.com/kingcons/coleslaw originally.

s3.lisp 1.8KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455
  1. (eval-when (:compile-toplevel :load-toplevel)
  2. (ql:quickload 'zs3))
  3. (defpackage :coleslaw-s3
  4. (:use :cl)
  5. (:import-from :coleslaw #:deploy
  6. #:deploy-dir
  7. #:*config*)
  8. (:export #:enable))
  9. (in-package :coleslaw-s3)
  10. (defparameter *content-type-map* '(("html" . "text/html")
  11. ("css" . "text/css")
  12. ("png" . "image/png")
  13. ("jpg" . "image/jpg"))
  14. "A mapping from file extensions to content types.")
  15. (defparameter *cache* (make-hash-table :test #'equal)
  16. "A cache of keys in a given bucket hashed by etag.")
  17. (defparameter *bucket* nil
  18. "A string designating the bucket to upload to.")
  19. (defun content-type (extension)
  20. (cdr (assoc extension *content-type-map* :test #'equal)))
  21. (defun stale-keys ()
  22. (loop for key being the hash-values in *cache* collecting key))
  23. (defun s3-sync (filepath dir)
  24. (let ((etag (zs3:file-etag filepath))
  25. (key (enough-namestring filepath dir)))
  26. (if (gethash etag *cache*)
  27. (remhash etag *cache*)
  28. (zs3:put-file filepath *bucket* key :public t
  29. :content-type (content-type (pathname-type filepath))))))
  30. (defun dir->s3 (dir)
  31. (flet ((upload (file) (s3-sync file dir)))
  32. (cl-fad:walk-directory dir #'upload)))
  33. (defmethod deploy :after (staging)
  34. (let ((blog (deploy-dir *config*)))
  35. (loop for key across (zs3:all-keys *bucket*)
  36. do (setf (gethash (zs3:etag key) *cache*) key))
  37. (dir->s3 blog)
  38. (zs3:delete-objects (stale-keys) *bucket*)))
  39. (defun enable (&key auth-file bucket)
  40. "AUTH-FILE: Path to file with the access key on the first line and the secret
  41. key on the second."
  42. (setf zs3:*credentials* (zs3:file-credentials auth-file)
  43. *bucket* bucket))