Updated version to 1.3.3.
[zs3.git] / credentials.lisp
blobdd60893b55b96fac338e91556a901a47baf837d4
1 ;;;;
2 ;;;; Copyright (c) 2008, 2015 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 ;;;; credentials.lisp
30 (in-package #:zs3)
32 (defvar *credentials* nil
33 "Used as the default initarg value of :CREDENTIALS when creating a
34 request.")
36 (define-condition unsupported-credentials (error)
37 ((object
38 :initarg :object
39 :accessor unsupported-credentials-object))
40 (:report (lambda (c s)
41 (format s "The value ~A is unsupported as S3 credentials. (Did you set *CREDENTIALS*?)~@
42 See http://www.xach.com/lisp/zs3/#*credentials* ~
43 for supported credentials formats."
44 (unsupported-credentials-object c)))))
46 (defgeneric access-key (credentials)
47 (:method (object)
48 (error 'unsupported-credentials :object object))
49 (:method ((list cons))
50 (first list)))
52 (defgeneric secret-key (credentials)
53 (:method (object)
54 (error 'unsupported-credentials :object object))
55 (:method ((list cons))
56 (second list)))
58 (defgeneric security-token (credentials)
59 (:method ((object t))
60 nil)
61 (:method ((list cons))
62 (third list)))
65 ;;; Lazy-loading credentials
67 (defclass lazy-credentials-mixin () ())
69 (defmethod slot-unbound ((class t) (credentials lazy-credentials-mixin)
70 (slot (eql 'access-key)))
71 (nth-value 0 (initialize-lazy-credentials credentials)))
73 (defmethod slot-unbound ((class t) (credentials lazy-credentials-mixin)
74 (slot (eql 'secret-key)))
75 (nth-value 1 (initialize-lazy-credentials credentials)))
77 (defmethod slot-unbound ((class t) (credentials lazy-credentials-mixin)
78 (slot (eql 'security-token)))
79 (nth-value 2 (initialize-lazy-credentials credentials)))
82 ;;; Loading credentials from a file
84 (defclass file-credentials (lazy-credentials-mixin)
85 ((file
86 :initarg :file
87 :accessor file)
88 (access-key
89 :accessor access-key)
90 (secret-key
91 :accessor secret-key)
92 (security-token
93 :accessor security-token)))
95 (defgeneric initialize-lazy-credentials (credentials)
96 (:method ((credentials file-credentials))
97 (with-open-file (stream (file credentials))
98 (values (setf (access-key credentials) (read-line stream))
99 (setf (secret-key credentials) (read-line stream))
100 (setf (security-token credentials) (read-line stream nil))))))
102 (defun file-credentials (file)
103 (make-instance 'file-credentials
104 :file file))