lifecycle.lisp

   1 ;;;;
   2 ;;;; Copyright (c) 2012 Zachary Beane, All Rights Reserved
   3 ;;;;
   4 ;;;; Redistribution and use in source and binary forms, with or without
   5 ;;;; modification, are permitted provided that the following conditions
   6 ;;;; are met:
   7 ;;;;
   8 ;;;;   * Redistributions of source code must retain the above copyright
   9 ;;;;     notice, this list of conditions and the following disclaimer.
  10 ;;;;
  11 ;;;;   * Redistributions in binary form must reproduce the above
  12 ;;;;     copyright notice, this list of conditions and the following
  13 ;;;;     disclaimer in the documentation and/or other materials
  14 ;;;;     provided with the distribution.
  15 ;;;;
  16 ;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  17 ;;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  18 ;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  19 ;;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  20 ;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  21 ;;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  22 ;;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  23 ;;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  24 ;;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  25 ;;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  26 ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  27 ;;;;
  28 ;;;; lifecycle.lisp
  29
  30 (in-package #:zs3)
  31
  32 ;;; Object expiration for buckets
  33
  34 (defbinder lifecycle-configuration
  35   ("LifecycleConfiguration"
  36    (sequence :rules
  37              ("Rule"
  38               ("ID" (bind :id))
  39               ("Prefix" (bind :prefix))
  40               ("Status" (bind :status))
  41               (alternate
  42                ("Expiration"
  43                 (alternate
  44                  ("Days" (bind :days))
  45                  ("Date" (bind :date))))
  46                ("Transition"
  47                 (alternate
  48                  ("Days" (bind :days))
  49                  ("Date" (bind :date)))
  50                 ("StorageClass" (bind :storage-class))))))))
  51
  52 (defclass lifecycle-rule ()
  53   ((id
  54     :initarg :id
  55     :accessor id)
  56    (prefix
  57     :initarg :prefix
  58     :accessor prefix)
  59    (enabledp
  60     :initarg :enabledp
  61     :accessor enabledp)
  62    (days
  63     :documentation
  64     "The number of days after which the rule action will take
  65     effect. Can be zero, meaning that it should take effect the next
  66     time Amazon's periodic transitioning process runs. One of DAYS or
  67     DATE must be provided."
  68     :initarg :days
  69     :accessor days)
  70    (date
  71     :documentation
  72     "The date at [XXX after?] which the rule takes effect. One of DAYS
  73     or DATE must be provided."
  74     :initarg :date
  75     :accessor date)
  76    (action
  77     :documentation
  78     "The action of this rule; must be either :EXPIRE (the default)
  79     or :TRANSITION. :TRANSITION means matching objects will transition
  80     to Glacier storage."
  81     :initarg :action
  82     :accessor action))
  83   (:documentation
  84    "A lifecycle rule. See
  85    http://docs.amazonwebservices.com/AmazonS3/latest/dev/object-lifecycle-mgmt.html#intro-lifecycle-rules.")
  86   (:default-initargs
  87    :prefix (string (gensym))
  88    :enabledp t
  89    :days nil
  90    :date nil
  91    :action :expire))
  92
  93 (defmethod print-object ((rule lifecycle-rule) stream)
  94   (print-unreadable-object (rule stream :type t)
  95     (format stream "~S ~(~A~) prefix ~S ~
  96                     ~:[on ~A~;in ~:*~D day~:P~*~] ~
  97                     (~:[disabled~;enabled~])"
  98             (id rule)
  99             (action rule)
 100             (prefix rule)
 101             (days rule)
 102             (date rule)
 103             (enabledp rule))))
 104
 105 ;;; FIXME: The GFs for ENABLE and DISABLE should really be moved
 106 ;;; somewhere out of cloudfront.lisp now that I'm adding more methods.
 107
 108 (defmethod disable ((rule lifecycle-rule))
 109   (setf (enabledp rule) nil))
 110
 111 (defmethod enable ((rule lifecycle-rule))
 112   (setf (enabledp rule) t))
 113
 114 (defun lifecycle-rule (&key id prefix (enabled t) days date
 115                        (action :expire))
 116   (unless id
 117     (setf id (string (gensym))))
 118   (unless prefix
 119     (error "Missing PREFIX argument"))
 120   (when (or (not (or days date))
 121             (and days date))
 122     (error "Exactly one of :DAYS or :DATE must be provided"))
 123   (make-instance 'lifecycle-rule
 124                  :id id
 125                  :prefix prefix
 126                  :enabledp enabled
 127                  :days days
 128                  :date date
 129                  :action action))
 130
 131 (defun lifecycle-document (rules)
 132   "Return an XML document that can be posted as the lifecycle
 133 configuration of a bucket. See
 134 http://docs.amazonwebservices.com/AmazonS3/latest/dev/object-lifecycle-mgmt.html#intro-lifecycle-rules
 135 for details."
 136   (flet ((timeframe-element (rule)
 137            (if (days rule)
 138                (with-element "Days"
 139                  (text (princ-to-string (days rule))))
 140                (with-element "Date"
 141                  (text (date rule))))))
 142     (with-xml-output
 143       (with-element "LifecycleConfiguration"
 144         (dolist (rule rules)
 145           (with-element "Rule"
 146             (with-element "ID"
 147               (text (id rule)))
 148             (with-element "Prefix"
 149               (text (prefix rule)))
 150             (with-element "Status"
 151               (text (if (enabledp rule)
 152                         "Enabled"
 153                         "Disabled")))
 154             (ecase (action rule)
 155               (:expire
 156                (with-element "Expiration"
 157                  (timeframe-element rule)))
 158               (:transition
 159                (with-element "Transition"
 160                  (timeframe-element rule)
 161                  (with-element "StorageClass"
 162                    (text "GLACIER")))))))))))
 163
 164 (defun bindings-lifecycle-rules (bindings)
 165   "Create a list of lifecycle rules from BINDINGS, which are obtained
 166 by xml-binding the LIFECYCLE-CONFIGURATION binder with a document."
 167   (let ((rules '()))
 168     (dolist (rule-bindings (bvalue :rules bindings) (nreverse rules))
 169       (alist-bind (id prefix status days date storage-class)
 170           rule-bindings
 171         (push (make-instance 'lifecycle-rule
 172                              :id id
 173                              :prefix prefix
 174                              :enabledp (string= status "Enabled")
 175                              :action (if storage-class
 176                                          :transition
 177                                          :expire)
 178                              :date date
 179                              :days (and days (parse-integer days)))
 180               rules)))))
 181
 182 (define-specific-error (no-such-lifecycle-configuration
 183                         "NoSuchLifecycleConfiguration")
 184     () ())
 185
 186 (defun bucket-lifecycle (bucket
 187                          &key ((:credentials *credentials*) *credentials*))
 188   "Return the bucket lifecycle rules for BUCKET. Signals
 189 NO-SUCH-LIFECYCLE-CONFIGURATION if the bucket has no lifecycle
 190 configuration."
 191   (let ((response
 192          (submit-request (make-instance 'request
 193                                         :method :get
 194                                         :bucket bucket
 195                                         :sub-resource "lifecycle"))))
 196     (bindings-lifecycle-rules
 197      (xml-bind 'lifecycle-configuration (body response)))))
 198
 199 (defun delete-bucket-lifecycle (bucket
 200                                 &key
 201                                 ((:credentials *credentials*) *credentials*))
 202   "Delete the lifecycle configuration of BUCKET."
 203   (submit-request (make-instance 'request
 204                                  :method :delete
 205                                  :bucket bucket
 206                                  :sub-resource "lifecycle")))
 207
 208 (defun (setf bucket-lifecycle) (rules bucket
 209                                 &key
 210                                 ((:credentials *credentials*) *credentials*))
 211   "Set the lifecycle configuration of BUCKET to RULES. RULES is
 212 coerced to a list if needed. If RULES is NIL, the lifecycle
 213 configuration is deleted with DELETE-BUCKET-LIFECYCLE."
 214   (when (null rules)
 215     (return-from bucket-lifecycle
 216       (delete-bucket-lifecycle bucket)))
 217   (unless (listp rules)
 218     (setf rules (list rules)))
 219   (let* ((content (lifecycle-document rules))
 220          (md5 (vector-md5/b64 content)))
 221     (submit-request (make-instance 'request
 222                                    :method :put
 223                                    :bucket bucket
 224                                    :sub-resource "lifecycle"
 225                                    :content-md5 md5
 226                                    :content content))))
 227
 228 ;;; Restoring from glacier
 229
 230 (defun restore-request-document (days)
 231   (with-xml-output
 232     (with-element "RestoreRequest"
 233       (with-element "Days"
 234         (text (princ-to-string days))))))
 235
 236 (defun restore-object (bucket key &key
 237                        days
 238                        ((:credentials *credentials*) *credentials*))
 239   (let* ((content (restore-request-document days))
 240          (md5 (vector-md5/b64 content)))
 241     (submit-request (make-instance 'request
 242                                    :method :post
 243                                    :content-md5 md5
 244                                    :sub-resource "restore"
 245                                    :bucket bucket
 246                                    :key key
 247                                    :content content))))
 248
 249 (defun object-restoration-status (bucket key &key
 250                                   ((:credentials *credentials*) *credentials*))
 251   (let ((headers (head :bucket bucket :key key)))
 252     (cdr (assoc :x-amz-restore headers))))
 253
 254 (define-specific-error (restore-already-in-progress
 255                         "RestoreAlreadyInProgress")
 256     () ())