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                            ((:backoff *backoff*) *backoff*))
 189   "Return the bucket lifecycle rules for BUCKET. Signals
 190 NO-SUCH-LIFECYCLE-CONFIGURATION if the bucket has no lifecycle
 191 configuration."
 192   (let ((response
 193          (submit-request (make-instance 'request
 194                                         :method :get
 195                                         :bucket bucket
 196                                         :sub-resource "lifecycle"))))
 197     (bindings-lifecycle-rules
 198      (xml-bind 'lifecycle-configuration (body response)))))
 199
 200 (defun delete-bucket-lifecycle (bucket
 201                                 &key
 202                                   ((:credentials *credentials*) *credentials*)
 203                                   ((:backoff *backoff*) *backoff*))
 204   "Delete the lifecycle configuration of BUCKET."
 205   (submit-request (make-instance 'request
 206                                  :method :delete
 207                                  :bucket bucket
 208                                  :sub-resource "lifecycle")))
 209
 210 (defun (setf bucket-lifecycle) (rules bucket
 211                                 &key
 212                                   ((:credentials *credentials*) *credentials*)
 213                                   ((:backoff *backoff*) *backoff*))
 214   "Set the lifecycle configuration of BUCKET to RULES. RULES is
 215 coerced to a list if needed. If RULES is NIL, the lifecycle
 216 configuration is deleted with DELETE-BUCKET-LIFECYCLE."
 217   (when (null rules)
 218     (return-from bucket-lifecycle
 219       (delete-bucket-lifecycle bucket)))
 220   (unless (listp rules)
 221     (setf rules (list rules)))
 222   (let* ((content (lifecycle-document rules))
 223          (md5 (vector-md5/b64 content)))
 224     (values
 225      rules
 226      (submit-request (make-instance 'request
 227                                     :method :put
 228                                     :bucket bucket
 229                                     :sub-resource "lifecycle"
 230                                     :content-md5 md5
 231                                     :content content)))))
 232
 233 ;;; Restoring from glacier
 234
 235 (defun restore-request-document (days)
 236   (with-xml-output
 237     (with-element "RestoreRequest"
 238       (with-element "Days"
 239         (text (princ-to-string days))))))
 240
 241 (defun restore-object (bucket key
 242                        &key
 243                          days
 244                          ((:credentials *credentials*) *credentials*)
 245                          ((:backoff *backoff*) *backoff*))
 246   (let* ((content (restore-request-document days))
 247          (md5 (vector-md5/b64 content)))
 248     (submit-request (make-instance 'request
 249                                    :method :post
 250                                    :content-md5 md5
 251                                    :sub-resource "restore"
 252                                    :bucket bucket
 253                                    :key key
 254                                    :content content))))
 255
 256 (defun object-restoration-status (bucket key
 257                                   &key
 258                                     ((:credentials *credentials*) *credentials*)
 259                                     ((:backoff *backoff*) *backoff*))
 260   (let ((headers (head :bucket bucket :key key)))
 261     (cdr (assoc :x-amz-restore headers))))
 262
 263 (define-specific-error (restore-already-in-progress
 264                         "RestoreAlreadyInProgress")
 265     () ())