redirects.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 ;;;; redirects.lisp
  29
  30 (in-package #:zs3)
  31
  32 (defvar *permanent-redirects*
  33   (make-hash-table :test 'equalp)
  34   "Some bucket operations make permanent redirects to different
  35 endpoints. This table stores access-key/bucket redirects for use when
  36 creating requests.")
  37
  38 (defun redirect-key (endpoint bucket &key
  39                      ((:credentials *credentials*) *credentials*))
  40   (list endpoint bucket (access-key *credentials*)))
  41
  42
  43 (defun redirection-data (endpoint bucket
  44                          &key ((:credentials *credentials*) *credentials*))
  45   (gethash (redirect-key endpoint bucket) *permanent-redirects*))
  46
  47 (defun redirected-endpoint (endpoint bucket
  48                             &key ((:credentials *credentials*) *credentials*))
  49   (or (first (redirection-data endpoint bucket)) endpoint))
  50
  51 (defun redirected-region (endpoint bucket &key
  52                           ((:credentials *credentials*) *credentials*))
  53   (second (redirection-data endpoint bucket)))
  54
  55 (defun (setf redirection-data) (new-value endpoint bucket
  56                                 &key ((:credentials *credentials*) *credentials*))
  57   (check-type new-value list)
  58   (let ((key (redirect-key endpoint bucket)))
  59     (if (not new-value)
  60         (progn (remhash key *permanent-redirects*) new-value)
  61         (setf (gethash key *permanent-redirects*) new-value))))
  62
  63 (defun clear-redirects ()
  64   (clrhash *permanent-redirects*))
  65