logging.lisp

   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
  29
  30 (in-package #:zs3)
  31
  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))
  46
  47 (defclass logging (response)
  48   ((setup
  49     :initarg :setup
  50     :accessor setup)))
  51
  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))))))))))
  65
  66
  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))))
  74
  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))))))))))
  87
  88
  89 (set-element-class "BucketLoggingStatus" 'logging)
  90
  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))
  96