Updated version to 1.3.3.
[zs3.git] / lifecycle.lisp
blob5588adda42774ce8cbbde62f54110a7daad5ae81
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
30 (in-package #:zs3)
32 ;;; Object expiration for buckets
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))))))))
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))
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))))
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.
108 (defmethod disable ((rule lifecycle-rule))
109 (setf (enabledp rule) nil))
111 (defmethod enable ((rule lifecycle-rule))
112 (setf (enabledp rule) t))
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))
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")))))))))))
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)))))
182 (define-specific-error (no-such-lifecycle-configuration
183 "NoSuchLifecycleConfiguration")
184 () ())
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)))))
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")))
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)))))
233 ;;; Restoring from glacier
235 (defun restore-request-document (days)
236 (with-xml-output
237 (with-element "RestoreRequest"
238 (with-element "Days"
239 (text (princ-to-string days))))))
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))))
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))))
263 (define-specific-error (restore-already-in-progress
264 "RestoreAlreadyInProgress")
265 () ())