Update copyright and mod dates to 2016.
[zs3.git] / lifecycle.lisp
blobb4a49d81204662c7946ed89166354dbbd726d2f0
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 "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)))))
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")))
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))))
228 ;;; Restoring from glacier
230 (defun restore-request-document (days)
231 (with-xml-output
232 (with-element "RestoreRequest"
233 (with-element "Days"
234 (text (princ-to-string days))))))
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))))
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))))
254 (define-specific-error (restore-already-in-progress
255 "RestoreAlreadyInProgress")
256 () ())