Updated version to 1.3.3.
[zs3.git] / logging.lisp
blobb1a8d7857f4f281f8413e914b1885a11d2ec5db0
1 ;;;;
2 ;;;; Copyright (c) 2008 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 ;;;; logging.lisp
30 (in-package #:zs3)
32 (defclass logging-setup ()
33 ((target-bucket
34 :initarg :target-bucket
35 :accessor target-bucket)
36 (target-prefix
37 :initarg :target-prefix
38 :accessor target-prefix)
39 (target-grants
40 :initarg :target-grants
41 :accessor target-grants))
42 (:default-initargs
43 :target-bucket nil
44 :target-prefix nil
45 :target-grants nil))
47 (defclass logging (response)
48 ((setup
49 :initarg :setup
50 :accessor setup)))
52 (defbinder bucket-logging-status
53 ("BucketLoggingStatus"
54 (optional
55 ("LoggingEnabled"
56 ("TargetBucket" (bind :target-bucket))
57 ("TargetPrefix" (bind :target-prefix))
58 (optional
59 ("TargetGrants"
60 (sequence :target-grants
61 ("Grant"
62 ("Grantee"
63 (elements-alist :grantee))
64 ("Permission" (bind :permission))))))))))
67 (defun bindings-logging-setup (bindings)
68 (alist-bind (target-bucket target-prefix target-grants)
69 bindings
70 (make-instance 'logging-setup
71 :target-bucket target-bucket
72 :target-prefix target-prefix
73 :target-grants (mapcar 'alist-grant target-grants))))
75 (defgeneric log-serialize (object)
76 (:method ((logging-setup logging-setup))
77 (with-xml-output
78 (with-element "BucketLoggingStatus"
79 (when (target-bucket logging-setup)
80 (with-element "LoggingEnabled"
81 (simple-element "TargetBucket" (target-bucket logging-setup))
82 (simple-element "TargetPrefix" (target-prefix logging-setup))
83 (when (target-grants logging-setup)
84 (with-element "TargetGrants"
85 (dolist (grant (target-grants logging-setup))
86 (acl-serialize grant))))))))))
89 (set-element-class "BucketLoggingStatus" 'logging)
91 (defmethod specialized-initialize ((response logging) source)
92 (let ((bindings (xml-bind 'bucket-logging-status source)))
93 (setf (setup response)
94 (bindings-logging-setup bindings))
95 response))