2 ;;;; Copyright (c) 2008 Zachary Beane, All Rights Reserved
4 ;;;; Redistribution and use in source and binary forms, with or without
5 ;;;; modification, are permitted provided that the following conditions
8 ;;;; * Redistributions of source code must retain the above copyright
9 ;;;; notice, this list of conditions and the following disclaimer.
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.
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.
32 (defvar *s3-endpoint
* "s3.amazonaws.com")
33 (defvar *use-ssl
* nil
)
34 (defvar *use-content-md5
* t
)
40 :documentation
"An object that has methods for ACCESS-KEY and
41 SECRET-KEY. A list of two strings (the keys) suffices.")
51 :documentation
"e.g. :GET, :PUT, :DELETE")
56 "A string naming the bucket to address in the request. If NIL,
57 request is not directed at a specific bucket.")
62 "A string naming the key to address in the request. If NIL,
63 request is not directed at a specific key.")
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.")
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
78 :initarg
:content-type
79 :accessor content-type
)
82 :accessor content-md5
)
84 :initarg
:content-length
85 :accessor content-length
)
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-\"
100 "An alist of extra Amazon request headers. These should be
101 straight string key/value pairs, WITHOUT any \"x-amz-\" prefix.")
106 :initarg
:signed-string
107 :accessor signed-string
)
109 :initarg
:extra-http-headers
110 :accessor extra-http-headers
111 :documentation
"An alist of extra HTTP headers to include in the request."))
113 ;; :date and :content-md5 are specially treated, should not be nil
114 :credentials
*credentials
*
116 :endpoint
*s3-endpoint
*
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
)
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"
150 (unless (integerp (content-length request
))
151 (let ((content (content request
)))
152 (setf (content-length request
)
155 (pathname (file-size content
))
156 (vector (length content
)))))))
158 (defgeneric http-method
(request)
160 (string-upcase (method request
))))
162 (defun puri-canonicalized-path (path)
163 (let ((parsed (puri:parse-uri
(format nil
"http://dummy~A" path
))))
164 (with-output-to-string (stream)
165 (if (puri:uri-path parsed
)
166 (write-string (puri:uri-path parsed
) stream
)
167 (write-string "/" stream
))
168 (when (puri:uri-query parsed
)
169 (write-string "?" stream
)
170 (write-string (puri:uri-query parsed
) stream
)))))
172 (defgeneric signed-path
(request)
174 (let ((*print-pretty
* nil
))
175 (puri-canonicalized-path
176 (with-output-to-string (stream)
177 (write-char #\
/ stream
)
178 (when (bucket request
)
179 (write-string (url-encode (name (bucket request
))) stream
)
180 (write-char #\
/ stream
))
182 (write-string (url-encode (name (key request
))) stream
))
183 (when (sub-resource request
)
184 (write-string "?" stream
)
185 (write-string (url-encode (sub-resource request
)) stream
)))))))
187 (defgeneric request-path
(request)
189 (let ((*print-pretty
* nil
))
190 (with-output-to-string (stream)
191 (write-char #\
/ stream
)
192 (when (and (bucket request
)
193 (string= (endpoint request
) *s3-endpoint
*))
194 (write-string (url-encode (name (bucket request
))) stream
)
195 (write-char #\
/ stream
))
197 (write-string (url-encode (name (key request
))) stream
))
198 (when (sub-resource request
)
199 (write-string "?" stream
)
200 (write-string (url-encode (sub-resource request
)) stream
))))))
202 (defgeneric all-amazon-headers
(request)
205 (loop for
((key . value
)) on
(amz-headers request
)
206 collect
(cons (format nil
"x-amz-~(~A~)" key
)
208 (loop for
((key . value
)) on
(metadata request
)
209 collect
(cons (format nil
"x-amz-meta-~(~A~)" key
)
212 (defgeneric amazon-header-signing-lines
(request)
214 ;; FIXME: handle values with commas, and repeated headers
215 (let* ((headers (all-amazon-headers request
))
216 (sorted (sort headers
#'string
< :key
#'car
)))
217 (loop for
((key . value
)) on sorted
218 collect
(format nil
"~A:~A" key value
)))))
220 (defgeneric date-string
(request)
222 (http-date-string (date request
))))
224 (defgeneric signature
(request)
226 (let ((digester (make-digester (secret-key request
))))
227 (flet ((maybe-add-line (string digester
)
229 (add-line string digester
)
230 (add-newline digester
))))
231 (add-line (http-method request
) digester
)
232 (maybe-add-line (content-md5 request
) digester
)
233 (maybe-add-line (content-type request
) digester
)
234 (add-line (date-string request
) digester
)
235 (dolist (line (amazon-header-signing-lines request
))
236 (add-line line digester
))
237 (add-string (signed-path request
) digester
)
238 (setf (signed-string request
)
239 (get-output-stream-string (signed-stream digester
)))
240 (digest64 digester
)))))
242 (defgeneric drakma-headers
(request)
245 (list* (cons "Date" (http-date-string (date request
)))
246 (cons "Authorization"
247 (format nil
"AWS ~A:~A"
249 (signature request
)))
250 (all-amazon-headers request
))))
251 (when (content-md5 request
)
252 (push (cons "Content-MD5" (content-md5 request
)) base
))
253 (append (extra-http-headers request
) base
))))
255 (defgeneric url
(request)
257 (format nil
"http~@[s~*~]://~A~A"
260 (request-path request
))))
262 (defun send-file-content (fun request
)
263 (with-open-file (stream (content request
)
264 :element-type
'(unsigned-byte 8))
265 (let* ((buffer-size 8000)
266 (buffer (make-octet-vector buffer-size
)))
267 (flet ((read-exactly (size)
268 (assert (= size
(read-sequence buffer stream
)))))
269 (multiple-value-bind (loops rest
)
270 (truncate (content-length request
) buffer-size
)
272 (read-exactly buffer-size
)
273 (funcall fun buffer t
))
275 (funcall fun
(subseq buffer
0 rest
) nil
))))))
277 (defgeneric send
(request &key want-stream
)
278 (:method
(request &key want-stream
)
280 (drakma:http-request
(url request
)
282 :want-stream want-stream
283 :content-type
(content-type request
)
284 :additional-headers
(drakma-headers request
)
285 :method
(method request
)
287 :content-length
(content-length request
)
288 :parameters
(parameters request
)
289 :content
:continuation
)))
290 (let ((content (content request
)))
291 (if (pathnamep content
)
292 (send-file-content continuation request
)
293 (funcall continuation content nil
))))))
295 (defmethod access-key ((request request
))
296 (access-key (credentials request
)))
298 (defmethod secret-key ((request request
))
299 (secret-key (credentials request
)))