2 ;;;; Copyright (c) 2012 Zachary Beane, All Rights Reserved
4 ;;;; Redistribution and use in source and binary forms, with or without
5 ;;;; modification, are permitted provided that the following conditions
8 ;;;; * Redistributions of source code must retain the above copyright
9 ;;;; notice, this list of conditions and the following disclaimer.
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.
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.
30 ;;; Object expiration for buckets
32 (defbinder lifecycle-configuration
33 ("LifecycleConfiguration"
37 ("Prefix" (bind :prefix
))
38 ("Status" (bind :status
))
40 ("Days" (bind :days
)))))))
42 (defclass lifecycle-rule
()
56 (defmethod print-object ((rule lifecycle-rule
) stream
)
57 (print-unreadable-object (rule stream
:type t
)
58 (format stream
"~S expire prefix ~S in ~D day~:P (~:[disabled~;enabled~])"
64 ;;; FIXME: The GFs for ENABLE and DISABLE should really be moved
65 ;;; somewhere out of cloudfront.lisp now that I'm adding more methods.
67 (defmethod disable ((rule lifecycle-rule
))
68 (setf (enabledp rule
) nil
))
70 (defmethod enable ((rule lifecycle-rule
))
71 (setf (enabledp rule
) t
))
73 (defun lifecycle-rule (&key id prefix
(enabled t
) days
)
75 (setf id
(string (gensym))))
77 (error "Missing PREFIX argument"))
79 (error "Missing DAYS argument"))
80 (make-instance 'lifecycle-rule
86 (defun lifecycle-document (rules)
87 (cxml:with-xml-output
(cxml:make-octet-vector-sink
)
88 (cxml:with-element
"LifecycleConfiguration"
90 (cxml:with-element
"Rule"
91 (cxml:with-element
"ID"
92 (cxml:text
(id rule
)))
93 (cxml:with-element
"Prefix"
94 (cxml:text
(prefix rule
)))
95 (cxml:with-element
"Status"
96 (cxml:text
(if (enabledp rule
)
99 (cxml:with-element
"Expiration"
100 (cxml:with-element
"Days"
101 (cxml:text
(princ-to-string (days rule
))))))))))
103 (defun bindings-lifecycle-rules (bindings)
105 (dolist (rule-bindings (bvalue :rules bindings
) (nreverse rules
))
106 (alist-bind (id prefix status days
)
108 (push (make-instance 'lifecycle-rule
111 :enabledp
(string= status
"Enabled")
112 :days
(parse-integer days
))
115 (defun bucket-lifecycle (bucket)
117 (submit-request (make-instance 'request
120 :sub-resource
"lifecycle"))))
121 (bindings-lifecycle-rules
122 (xml-bind 'lifecycle-configuration
(body response
)))))
124 (defun delete-bucket-lifecycle (bucket)
125 (submit-request (make-instance 'request
128 :sub-resource
"lifecycle")))
130 (defun set-bucket-lifecycle (bucket rules
)
132 (setf rules
(list rules
)))
133 (let* ((content (lifecycle-document rules
))
134 (md5 (vector-md5/b64 content
)))
135 (submit-request (make-instance 'request
138 :sub-resource
"lifecycle"