Updated version to 1.3.3.
[zs3.git] / request.lisp
bloba1c2c42cccd50d40a361047515efd18badd9637a
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 ;;;; request.lisp
30 (in-package #:zs3)
32 (defvar *s3-endpoint* "s3.amazonaws.com")
33 (defvar *s3-region* "us-east-1")
34 (defvar *use-ssl* nil)
35 (defvar *use-content-md5* t)
36 (defvar *signed-payload* nil
37 "When true, compute the SHA256 hash for the body of all requests
38 when submitting to AWS.")
40 (defvar *use-keep-alive* nil
41 "When set to t, this library uses the drakma client with
42 keep alive enabled. This means that a stream will be reused for multiple
43 requests. The stream itself will be bound to *keep-alive-stream*")
46 (defvar *keep-alive-stream* nil
47 "When using http keep-alive, this variable is bound to the stream
48 which is being kept open for repeated usage. It is up to client code
49 to ensure that only one thread at a time is making requests that
50 could use the same stream object concurrently. One way to achive
51 this would be to create a separate binding per thread. The
52 with-keep-alive macro can be useful here.")
55 (defmacro with-keep-alive (&body body)
56 "Create thread-local bindings of the zs3 keep-alive variables around a
57 body of code. Ensure the stream is closed at exit."
58 `(let ((*use-keep-alive* t)
59 (*keep-alive-stream* nil))
60 (unwind-protect
61 (progn ,@body)
62 (when *keep-alive-stream*
63 (ignore-errors (close *keep-alive-stream*))))))
66 (defclass request ()
67 ((credentials
68 :initarg :credentials
69 :accessor credentials
70 :documentation "An object that has methods for ACCESS-KEY and
71 SECRET-KEY. A list of two strings (the keys) suffices.")
72 (endpoint
73 :initarg :endpoint
74 :accessor endpoint)
75 (region
76 :initarg :region
77 :accessor region)
78 (ssl
79 :initarg :ssl
80 :accessor ssl)
81 (method
82 :initarg :method
83 :accessor method
84 :documentation "e.g. :GET, :PUT, :DELETE")
85 (bucket
86 :initarg :bucket
87 :accessor bucket
88 :documentation
89 "A string naming the bucket to address in the request. If NIL,
90 request is not directed at a specific bucket.")
91 (key
92 :initarg :key
93 :accessor key
94 :documentation
95 "A string naming the key to address in the request. If NIL,
96 request is not directed at a specific key.")
97 (sub-resource
98 :initarg :sub-resource
99 :accessor sub-resource
100 :documentation "A sub-resource to address as part of the request,
101 without a leading \"?\", e.g. \"acl\", \"torrent\". If PARAMETERS
102 is set, this must be NIL.")
103 (parameters
104 :initarg :parameters
105 :accessor parameters
106 :documentation
107 "An alist of string key/value pairs to send as CGI-style GET
108 parameters with the request. If SUB-RESOURCE is set, these must be
109 NIL.")
110 (content-type
111 :initarg :content-type
112 :accessor content-type)
113 (content-md5
114 :initarg :content-md5
115 :accessor content-md5)
116 (content-length
117 :initarg :content-length
118 :accessor content-length)
119 (content
120 :initarg :content
121 :accessor content)
122 (metadata
123 :initarg :metadata
124 :accessor metadata
125 :documentation
126 "An alist of Amazon metadata to attach to a request. These should
127 be straight string key/value pairs, WITHOUT any \"x-amz-meta-\"
128 prefix.")
129 (amz-headers
130 :initarg :amz-headers
131 :accessor amz-headers
132 :documentation
133 "An alist of extra Amazon request headers. These should be
134 straight string key/value pairs, WITHOUT any \"x-amz-\" prefix.")
135 (date
136 :initarg :date
137 :accessor date)
138 (signed-string
139 :initarg :signed-string
140 :accessor signed-string)
141 (extra-http-headers
142 :initarg :extra-http-headers
143 :accessor extra-http-headers
144 :documentation "An alist of extra HTTP headers to include in the request."))
145 (:default-initargs
146 ;; :date and :content-md5 are specially treated, should not be nil
147 :credentials *credentials*
148 :method :get
149 :endpoint *s3-endpoint*
150 :region *s3-region*
151 :ssl *use-ssl*
152 :bucket nil
153 :key nil
154 :sub-resource nil
155 :parameters nil
156 :content-type nil
157 :content-length t
158 :content nil
159 :metadata nil
160 :amz-headers nil
161 :extra-http-headers nil))
163 (defmethod slot-unbound ((class t) (request request) (slot (eql 'date)))
164 (setf (date request) (get-universal-time)))
166 (defmethod slot-unbound ((class t) (request request) (slot (eql 'content-md5)))
167 (setf (content-md5 request)
168 (when *use-content-md5*
169 (let ((content (content request)))
170 (cond ((pathnamep content) (file-md5/b64 content))
171 ((stringp content)
172 (vector-md5/b64
173 (flexi-streams:string-to-octets content)))
174 ((vectorp content) (vector-md5/b64 content)))))))
176 (defmethod slot-unbound ((class t) (request request) (slot (eql 'signed-string)))
177 (setf (signed-string request)
178 (format nil "~{~A~^~%~}" (string-to-sign-lines request))))
180 (defgeneric amz-header-value (request name)
181 (:method (request name)
182 (cdr (assoc name (amz-headers request) :test 'string=))))
184 (defgeneric ensure-amz-header (request name value)
185 (:method (request name value)
186 (unless (amz-header-value request name)
187 (push (cons name value) (amz-headers request)))))
189 (defmethod initialize-instance :after ((request request)
190 &rest initargs &key
191 &allow-other-keys)
192 (declare (ignore initargs))
193 (when (eql (method request) :head)
194 ;; https://forums.aws.amazon.com/thread.jspa?messageID=340398 -
195 ;; when using the bare endpoint, the 301 redirect for a HEAD
196 ;; request does not include enough info to actually redirect. Use
197 ;; the bucket endpoint pre-emptively instead
198 (setf (endpoint request) (format nil "~A.~A"
199 (bucket request)
200 *s3-endpoint*)))
201 (ensure-amz-header request "date"
202 (iso8601-basic-timestamp-string (date request)))
203 (ensure-amz-header request "content-sha256"
204 (payload-sha256 request))
205 (let ((target-region (redirected-region (endpoint request)
206 (bucket request))))
207 (when target-region
208 (setf (region request) target-region)))
209 (when (content-md5 request)
210 (push (cons "Content-MD5" (content-md5 request)) (extra-http-headers request)))
211 (unless (integerp (content-length request))
212 (let ((content (content request)))
213 (setf (content-length request)
214 (etypecase content
215 (null 0)
216 (pathname (file-size content))
217 (vector (length content)))))))
219 (defgeneric host (request)
220 (:method ((request request))
221 (or (redirected-endpoint (endpoint request) (bucket request))
222 (endpoint request))))
224 (defgeneric http-method (request)
225 (:method (request)
226 (string-upcase (method request))))
228 (defun puri-canonicalized-path (path)
229 (let ((parsed (puri:parse-uri (format nil "http://dummy~A" path))))
230 (with-output-to-string (stream)
231 (if (puri:uri-path parsed)
232 (write-string (puri:uri-path parsed) stream)
233 (write-string "/" stream))
234 (when (puri:uri-query parsed)
235 (write-string "?" stream)
236 (write-string (puri:uri-query parsed) stream)))))
238 (defgeneric signed-path (request)
239 (:method (request)
240 (let ((*print-pretty* nil))
241 (puri-canonicalized-path
242 (with-output-to-string (stream)
243 (write-char #\/ stream)
244 (when (bucket request)
245 (write-string (url-encode (name (bucket request))) stream)
246 (write-char #\/ stream))
247 (when (key request)
248 (write-string (url-encode (name (key request)) :encode-slash nil)
249 stream))
250 (when (sub-resource request)
251 (write-string "?" stream)
252 (write-string (url-encode (sub-resource request)) stream)))))))
254 (defgeneric request-path (request)
255 (:method (request)
256 (let ((*print-pretty* nil))
257 (with-output-to-string (stream)
258 (write-char #\/ stream)
259 (when (and (bucket request)
260 (string= (endpoint request)
261 (region-endpoint (region request))))
262 (write-string (url-encode (name (bucket request))) stream)
263 (write-char #\/ stream))
264 (when (key request)
265 (write-string (url-encode (name (key request))
266 :encode-slash nil) stream))
267 (when (sub-resource request)
268 (write-string "?" stream)
269 (write-string (url-encode (sub-resource request)) stream))))))
271 (defgeneric all-amazon-headers (request)
272 (:method (request)
273 (nconc
274 (loop for ((key . value)) on (amz-headers request)
275 collect (cons (format nil "x-amz-~(~A~)" key)
276 value))
277 (loop for ((key . value)) on (metadata request)
278 collect (cons (format nil "x-amz-meta-~(~A~)" key)
279 value)))))
281 (defgeneric date-string (request)
282 (:method (request)
283 (http-date-string (date request))))
285 ;;; AWS 4 authorization
287 (defun headers-for-signing (request)
288 (append (all-amazon-headers request)
289 (extra-http-headers request)
290 (parameters-alist "host" (host request)
291 "content-type" (content-type request))))
293 (defun canonical-headers (headers)
294 (flet ((trim (string)
295 (string-trim " " string)))
296 (let ((encoded
297 (loop for (name . value) in headers
298 collect (cons (string-downcase name)
299 (trim value)))))
300 (sort encoded #'string< :key 'car))))
302 (defun signed-headers (request)
303 (mapcar 'first (canonical-headers (headers-for-signing request))))
305 (defun parameters-for-signing (request)
306 (cond ((sub-resource request)
307 (list (cons (sub-resource request) "")))
309 (parameters request))))
311 (defun canonical-parameters (parameters)
312 (let ((encoded
313 (loop for (name . value) in parameters
314 collect (cons
315 (url-encode name)
316 (url-encode value)))))
317 (sort encoded #'string< :key 'car)))
319 (defun canonical-parameters-string (request)
320 (format nil "~{~A=~A~^&~}"
321 (alist-plist (canonical-parameters
322 (parameters-for-signing request)))))
324 (defun path-to-sign (request)
325 "Everything in the PATH of the request, up to the first ?"
326 (let ((path (request-path request)))
327 (subseq path 0 (position #\? path))))
329 (defun canonicalized-request-lines (request)
330 "Return a list of lines canonicalizing the request according to
331 http://docs.aws.amazon.com/AmazonS3/latest/API/sig-v4-header-based-auth.html."
332 (let* ((headers (headers-for-signing request))
333 (canonical-headers (canonical-headers headers)))
334 (alexandria:flatten
335 (list (http-method request)
336 (path-to-sign request)
337 (canonical-parameters-string request)
338 (loop for (name . value) in canonical-headers
339 collect (format nil "~A:~A" name value))
341 (format nil "~{~A~^;~}" (signed-headers request))
342 (or (amz-header-value request "content-sha256")
343 "UNSIGNED-PAYLOAD")))))
345 (defun string-to-sign-lines (request)
346 "Return a list of strings to sign to construct the Authorization header."
347 (list "AWS4-HMAC-SHA256"
348 (iso8601-basic-timestamp-string (date request))
349 (with-output-to-string (s)
350 (format s "~A/~A/s3/aws4_request"
351 (iso8601-basic-date-string (date request))
352 (region request)))
353 (strings-sha256/hex (canonicalized-request-lines request))))
355 (defun make-signing-key (credentials &key region service)
356 "The signing key is derived from the credentials, region, date, and
357 service. A signing key could be saved, shared, and reused, but ZS3 just recomputes it all the time instead."
358 (let* ((k1 (format nil "AWS4~A" (secret-key credentials)))
359 (date-key (hmac-sha256 k1 (iso8601-basic-date-string)))
360 (region-key (hmac-sha256 date-key region))
361 (service-key (hmac-sha256 region-key service)))
362 (hmac-sha256 service-key "aws4_request")))
364 (defun payload-sha256 (request)
365 (if *signed-payload*
366 (let ((payload (content request)))
367 (etypecase payload
368 ((or null empty-vector)
369 *empty-string-sha256*)
370 (vector
371 (vector-sha256/hex payload))
372 (pathname
373 (file-sha256/hex payload))))
374 "UNSIGNED-PAYLOAD"))
376 (defun request-signature (request)
377 (let ((key (make-signing-key *credentials*
378 :region (region request)
379 :service "s3")))
380 (strings-hmac-sha256/hex key (string-to-sign-lines request) )))
382 (defmethod authorization-header-value ((request request))
383 (let ((key (make-signing-key *credentials*
384 :region (region request)
385 :service "s3"))
386 (lines (string-to-sign-lines request)))
387 (with-output-to-string (s)
388 (write-string "AWS4-HMAC-SHA256" s)
389 (format s " Credential=~A/~A/~A/s3/aws4_request"
390 (access-key *credentials*)
391 (iso8601-basic-date-string (date request))
392 (region request))
393 (format s ",SignedHeaders=~{~A~^;~}" (signed-headers request))
394 (format s ",Signature=~A"
395 (strings-hmac-sha256/hex key lines)))))
397 (defgeneric drakma-headers (request)
398 (:method (request)
399 (let ((base
400 (list* (cons "Date" (http-date-string (date request)))
401 (cons "Authorization"
402 (authorization-header-value request))
403 (all-amazon-headers request))))
404 (append (extra-http-headers request) base))))
406 (defgeneric url (request)
407 (:method (request)
408 (format nil "http~@[s~*~]://~A~A"
409 (ssl request)
410 (endpoint request)
411 (request-path request))))
413 (defun send-file-content (fun request)
414 (with-open-file (stream (content request)
415 :element-type '(unsigned-byte 8))
416 (let* ((buffer-size 8000)
417 (buffer (make-octet-vector buffer-size)))
418 (flet ((read-exactly (size)
419 (assert (= size (read-sequence buffer stream)))))
420 (multiple-value-bind (loops rest)
421 (truncate (content-length request) buffer-size)
422 (dotimes (i loops)
423 (read-exactly buffer-size)
424 (funcall fun buffer t))
425 (read-exactly rest)
426 (funcall fun (subseq buffer 0 rest) nil))))))
428 (defgeneric send (request &key want-stream stream)
429 (:method (request &key want-stream stream)
430 (let ((continuation
431 (drakma:http-request (url request)
432 :redirect nil
433 :want-stream want-stream
434 :stream stream
435 :keep-alive *use-keep-alive*
436 :close (not *use-keep-alive*)
437 :content-type (content-type request)
438 :additional-headers (drakma-headers request)
439 :method (method request)
440 :force-binary t
441 :content-length (content-length request)
442 :parameters (parameters request)
443 :content :continuation)))
444 (let ((content (content request)))
445 (if (pathnamep content)
446 (send-file-content continuation request)
447 (funcall continuation content nil))))))
449 (defmethod access-key ((request request))
450 (access-key (credentials request)))
452 (defmethod secret-key ((request request))
453 (secret-key (credentials request)))
455 (defmethod security-token ((request request))
456 (security-token (credentials request)))