Sync up new redirect interface with its uses.
[zs3.git] / request.lisp
blob75f7ac4dc41029e0bda4a5d5c86ba1f3e19a8c1d
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 ;;;; request.lisp
30 (in-package #:zs3)
32 (defvar *s3-endpoint* "s3.amazonaws.com")
33 (defvar *use-ssl* nil)
34 (defvar *use-content-md5* t)
36 (defclass request ()
37 ((credentials
38 :initarg :credentials
39 :accessor credentials
40 :documentation "An object that has methods for ACCESS-KEY and
41 SECRET-KEY. A list of two strings (the keys) suffices.")
42 (endpoint
43 :initarg :endpoint
44 :accessor endpoint)
45 (ssl
46 :initarg :ssl
47 :accessor ssl)
48 (method
49 :initarg :method
50 :accessor method
51 :documentation "e.g. :GET, :PUT, :DELETE")
52 (bucket
53 :initarg :bucket
54 :accessor bucket
55 :documentation
56 "A string naming the bucket to address in the request. If NIL,
57 request is not directed at a specific bucket.")
58 (key
59 :initarg :key
60 :accessor key
61 :documentation
62 "A string naming the key to address in the request. If NIL,
63 request is not directed at a specific key.")
64 (sub-resource
65 :initarg :sub-resource
66 :accessor sub-resource
67 :documentation "A sub-resource to address as part of the request,
68 without a leading \"?\", e.g. \"acl\", \"torrent\". If PARAMETERS
69 is set, this must be NIL.")
70 (parameters
71 :initarg :parameters
72 :accessor parameters
73 :documentation
74 "An alist of string key/value pairs to send as CGI-style GET
75 parameters with the request. If SUB-RESOURCE is set, these must be
76 NIL.")
77 (content-type
78 :initarg :content-type
79 :accessor content-type)
80 (content-md5
81 :initarg :content-md5
82 :accessor content-md5)
83 (content-length
84 :initarg :content-length
85 :accessor content-length)
86 (content
87 :initarg :content
88 :accessor content)
89 (metadata
90 :initarg :metadata
91 :accessor metadata
92 :documentation
93 "An alist of Amazon metadata to attach to a request. These should
94 be straight string key/value pairs, WITHOUT any \"x-amz-meta-\"
95 prefix.")
96 (amz-headers
97 :initarg :amz-headers
98 :accessor amz-headers
99 :documentation
100 "An alist of extra Amazon request headers. These should be
101 straight string key/value pairs, WITHOUT any \"x-amz-\" prefix.")
102 (date
103 :initarg :date
104 :accessor date)
105 (signed-string
106 :initarg :signed-string
107 :accessor signed-string)
108 (extra-http-headers
109 :initarg :extra-http-headers
110 :accessor extra-http-headers
111 :documentation "An alist of extra HTTP headers to include in the request."))
112 (:default-initargs
113 ;; :date and :content-md5 are specially treated, should not be nil
114 :credentials *credentials*
115 :method :get
116 :endpoint *s3-endpoint*
117 :ssl *use-ssl*
118 :bucket nil
119 :key nil
120 :sub-resource nil
121 :parameters nil
122 :content-type nil
123 :content-length t
124 :content nil
125 :metadata nil
126 :amz-headers nil
127 :extra-http-headers nil))
129 (defmethod slot-unbound ((class t) (request request) (slot (eql 'date)))
130 (setf (date request) (get-universal-time)))
132 (defmethod slot-unbound ((class t) (request request) (slot (eql 'content-md5)))
133 (setf (content-md5 request)
134 (and *use-content-md5*
135 (pathnamep (content request))
136 (file-md5/b64 (content request)))))
138 (defmethod initialize-instance :after ((request request)
139 &rest initargs &key
140 &allow-other-keys)
141 (declare (ignore initargs))
142 (when (eql (method request) :head)
143 ;; https://forums.aws.amazon.com/thread.jspa?messageID=340398 -
144 ;; when using the bare endpoint, the 301 redirect for a HEAD
145 ;; request does not include enough info to actually redirect. Use
146 ;; the bucket endpoint pre-emptively instead
147 (setf (endpoint request) (format nil "~A.~A"
148 (bucket request)
149 *s3-endpoint*)))
150 (unless (integerp (content-length request))
151 (let ((content (content request)))
152 (setf (content-length request)
153 (etypecase content
154 (null 0)
155 (pathname (file-size content))
156 (vector (length content)))))))
158 (defgeneric host (request)
159 (:method ((request request))
160 (or (redirected-endpoint (endpoint request) (bucket request))
161 (endpoint request))))
163 (defgeneric http-method (request)
164 (:method (request)
165 (string-upcase (method request))))
167 (defun puri-canonicalized-path (path)
168 (let ((parsed (puri:parse-uri (format nil "http://dummy~A" path))))
169 (with-output-to-string (stream)
170 (if (puri:uri-path parsed)
171 (write-string (puri:uri-path parsed) stream)
172 (write-string "/" stream))
173 (when (puri:uri-query parsed)
174 (write-string "?" stream)
175 (write-string (puri:uri-query parsed) stream)))))
177 (defgeneric signed-path (request)
178 (:method (request)
179 (let ((*print-pretty* nil))
180 (puri-canonicalized-path
181 (with-output-to-string (stream)
182 (write-char #\/ stream)
183 (when (bucket request)
184 (write-string (url-encode (name (bucket request))) stream)
185 (write-char #\/ stream))
186 (when (key request)
187 (write-string (url-encode (name (key request)) :encode-slash nil)
188 stream))
189 (when (sub-resource request)
190 (write-string "?" stream)
191 (write-string (url-encode (sub-resource request)) stream)))))))
193 (defgeneric request-path (request)
194 (:method (request)
195 (let ((*print-pretty* nil))
196 (with-output-to-string (stream)
197 (write-char #\/ stream)
198 (when (and (bucket request)
199 (string= (endpoint request) *s3-endpoint*))
200 (write-string (url-encode (name (bucket request))) stream)
201 (write-char #\/ stream))
202 (when (key request)
203 (write-string (url-encode (name (key request))
204 :encode-slash nil) stream))
205 (when (sub-resource request)
206 (write-string "?" stream)
207 (write-string (url-encode (sub-resource request)) stream))))))
209 (defgeneric all-amazon-headers (request)
210 (:method (request)
211 (nconc
212 (loop for ((key . value)) on (amz-headers request)
213 collect (cons (format nil "x-amz-~(~A~)" key)
214 value))
215 (loop for ((key . value)) on (metadata request)
216 collect (cons (format nil "x-amz-meta-~(~A~)" key)
217 value)))))
219 (defgeneric amazon-header-signing-lines (request)
220 (:method (request)
221 ;; FIXME: handle values with commas, and repeated headers
222 (let* ((headers (all-amazon-headers request))
223 (sorted (sort headers #'string< :key #'car)))
224 (loop for ((key . value)) on sorted
225 collect (format nil "~A:~A" key value)))))
227 (defgeneric date-string (request)
228 (:method (request)
229 (http-date-string (date request))))
231 (defgeneric signature (request)
232 (:method (request)
233 (let ((digester (make-digester (secret-key request))))
234 (flet ((maybe-add-line (string digester)
235 (if string
236 (add-line string digester)
237 (add-newline digester))))
238 (add-line (http-method request) digester)
239 (maybe-add-line (content-md5 request) digester)
240 (maybe-add-line (content-type request) digester)
241 (add-line (date-string request) digester)
242 (dolist (line (amazon-header-signing-lines request))
243 (add-line line digester))
244 (add-string (signed-path request) digester)
245 (setf (signed-string request)
246 (get-output-stream-string (signed-stream digester)))
247 (digest64 digester)))))
249 (defgeneric authorization-header-value (request)
250 (:method (request)
251 (format nil "AWS ~A:~A"
252 (access-key request)
253 (signature request))))
255 (defgeneric drakma-headers (request)
256 (:method (request)
257 (let ((base
258 (list* (cons "Date" (http-date-string (date request)))
259 (cons "Authorization"
260 (authorization-header-value request))
261 (all-amazon-headers request))))
262 (when (content-md5 request)
263 (push (cons "Content-MD5" (content-md5 request)) base))
264 (append (extra-http-headers request) base))))
266 (defgeneric url (request)
267 (:method (request)
268 (format nil "http~@[s~*~]://~A~A"
269 (ssl request)
270 (endpoint request)
271 (request-path request))))
273 (defun send-file-content (fun request)
274 (with-open-file (stream (content request)
275 :element-type '(unsigned-byte 8))
276 (let* ((buffer-size 8000)
277 (buffer (make-octet-vector buffer-size)))
278 (flet ((read-exactly (size)
279 (assert (= size (read-sequence buffer stream)))))
280 (multiple-value-bind (loops rest)
281 (truncate (content-length request) buffer-size)
282 (dotimes (i loops)
283 (read-exactly buffer-size)
284 (funcall fun buffer t))
285 (read-exactly rest)
286 (funcall fun (subseq buffer 0 rest) nil))))))
288 (defgeneric send (request &key want-stream)
289 (:method (request &key want-stream)
290 (let ((continuation
291 (drakma:http-request (url request)
292 :redirect nil
293 :want-stream want-stream
294 :content-type (content-type request)
295 :additional-headers (drakma-headers request)
296 :method (method request)
297 :force-binary t
298 :content-length (content-length request)
299 :parameters (parameters request)
300 :content :continuation)))
301 (let ((content (content request)))
302 (if (pathnamep content)
303 (send-file-content continuation request)
304 (funcall continuation content nil))))))
306 (defmethod access-key ((request request))
307 (access-key (credentials request)))
309 (defmethod secret-key ((request request))
310 (secret-key (credentials request)))