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

s3.lisp 1.9KB

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