Updated version to 1.3.3.
[zs3.git] / cloudfront.lisp
blob3623a7e22b8633dd6d713f685e63be0002f1b4a1
1 ;;;;
2 ;;;; Copyright (c) 2009 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 ;;;; cloudfront.lisp
30 (in-package #:zs3)
32 (defvar *canonical-bucket-name-suffix*
33 ".s3.amazonaws.com")
35 (defparameter *caller-reference-counter* 8320208)
37 (defparameter *cloudfront-base-url*
38 "https://cloudfront.amazonaws.com/2010-08-01/distribution")
40 ;;; Errors
42 (defparameter *distribution-specific-errors*
43 (make-hash-table :test 'equal)
44 "This table is used to signal the most specific error possible for
45 distribution request error responses.")
47 (defbinder distribution-error-response
48 ("ErrorResponse"
49 ("Error"
50 ("Type" (bind :type))
51 ("Code" (bind :code))
52 ("Message" (bind :message))
53 (optional
54 ("Detail" (bind :detail))))
55 ("RequestId" (bind :request-id))))
57 (define-condition distribution-error (error)
58 ((error-type
59 :initarg :error-type
60 :accessor distribution-error-type)
61 (error-code
62 :initarg :error-code
63 :accessor distribution-error-code)
64 (http-status-code
65 :initarg :http-status-code
66 :accessor distribution-error-http-status-code)
67 (error-message
68 :initarg :error-message
69 :accessor distribution-error-message)
70 (error-detail
71 :initarg :error-detail
72 :accessor distribution-error-detail))
73 (:report (lambda (condition stream)
74 (format stream "~A error ~A: ~A"
75 (distribution-error-type condition)
76 (distribution-error-code condition)
77 (distribution-error-message condition)))))
79 (defmacro define-specific-distribution-error (error-xml-code error-name)
80 `(progn
81 (setf (gethash ,error-xml-code *distribution-specific-errors*)
82 ',error-name)
83 (define-condition ,error-name (distribution-error) ())))
85 (define-specific-distribution-error "InvalidIfMatchVersion"
86 invalid-if-match-version)
88 (define-specific-distribution-error "PreconditionFailed"
89 distribution-precondition-failed)
91 (define-specific-distribution-error "DistributionNotDisabled"
92 distribution-not-disabled)
94 (define-specific-distribution-error "CNAMEAlreadyExists"
95 cname-already-exists)
97 (define-specific-distribution-error "TooManyDistributions"
98 too-many-distributions)
100 (defun maybe-signal-distribution-error (http-status-code content)
101 (when (and content
102 (plusp (length content))
103 (string= (xml-document-element content) "ErrorResponse"))
104 (let* ((bindings (xml-bind 'distribution-error-response
105 content))
106 (condition (gethash (bvalue :code bindings)
107 *distribution-specific-errors*
108 'distribution-error)))
109 (error condition
110 :http-status-code http-status-code
111 :error-type (bvalue :type bindings)
112 :error-code (bvalue :code bindings)
113 :error-message (bvalue :message bindings)
114 :error-detail (bvalue :detail bindings)))))
117 ;;; Distribution objects
119 (defun canonical-distribution-bucket-name (name)
120 (if (ends-with *canonical-bucket-name-suffix* name)
121 name
122 (concatenate 'string name *canonical-bucket-name-suffix*)))
124 (defun generate-caller-reference ()
125 (format nil "~D.~D"
126 (get-universal-time)
127 (incf *caller-reference-counter*)))
129 (defclass distribution ()
130 ((origin-bucket
131 :initarg :origin-bucket
132 :accessor origin-bucket
133 :documentation
134 "The S3 bucket that acts as the source of objects for the distribution.")
135 (caller-reference
136 :initarg :caller-reference
137 :accessor caller-reference
138 :initform (generate-caller-reference)
139 :documentation
140 "A unique value provided by the caller to prevent replays. See
141 http://docs.amazonwebservices.com/AmazonCloudFront/2008-06-30/DeveloperGuide/index.html?AboutCreatingDistributions.html")
142 (enabledp
143 :initarg :enabledp
144 :initform t
145 :accessor enabledp
146 :documentation
147 "Whether this distribution should be enabled at creation time or not.")
148 (cnames
149 :initarg :cnames
150 :accessor cnames)
151 (default-root-object
152 :initarg :default-root-object
153 :accessor default-root-object
154 :initform nil)
155 (comment
156 :initarg :comment
157 :initform nil
158 :accessor comment)
159 (logging-bucket
160 :initarg :logging-bucket
161 :initform nil
162 :accessor logging-bucket)
163 (logging-prefix
164 :initarg :logging-prefix
165 :initform nil
166 :accessor logging-prefix)
168 :initarg :id
169 :accessor id
170 :documentation
171 "Amazon's assigned unique ID.")
172 (domain-name
173 :initarg :domain-name
174 :accessor domain-name
175 :documentation
176 "Amazon's assigned domain name.")
177 (etag
178 :initarg :etag
179 :accessor etag
180 :initform nil)
181 (status
182 :initarg :status
183 :accessor status
184 :initform nil
185 :documentation "Assigned by Amazon.")
186 (last-modified
187 :initarg :last-modified
188 :accessor last-modified
189 :documentation "Assigned by Amazon.")))
191 (defmethod print-object ((distribution distribution) stream)
192 (print-unreadable-object (distribution stream :type t)
193 (format stream "~A for ~S~@[ [~A]~]"
194 (id distribution)
195 (origin-bucket distribution)
196 (status distribution))))
198 (defmethod initialize-instance :after ((distribution distribution)
199 &rest initargs
200 &key &allow-other-keys)
201 (declare (ignore initargs))
202 (setf (origin-bucket distribution)
203 (canonical-distribution-bucket-name (origin-bucket distribution))))
206 ;;; Distribution-related requests
208 (defun distribution-document (distribution)
209 (with-xml-output
210 (with-element "DistributionConfig"
211 (attribute "xmlns" "http://cloudfront.amazonaws.com/doc/2010-08-01/")
212 (with-element "Origin"
213 (text (origin-bucket distribution)))
214 (with-element "CallerReference"
215 (text (caller-reference distribution)))
216 (dolist (cname (cnames distribution))
217 (with-element "CNAME"
218 (text cname)))
219 (when (comment distribution)
220 (with-element "Comment"
221 (text (comment distribution))))
222 (with-element "Enabled"
223 (text (if (enabledp distribution)
224 "true"
225 "false")))
226 (when (default-root-object distribution)
227 (with-element "DefaultRootObject"
228 (text (default-root-object distribution))))
229 (let ((logging-bucket (logging-bucket distribution))
230 (logging-prefix (logging-prefix distribution)))
231 (when (and logging-bucket logging-prefix)
232 (with-element "Logging"
233 (with-element "Bucket" (text logging-bucket))
234 (with-element "Prefix" (text logging-prefix))))))))
236 (defun distribution-request-headers (distribution)
237 (let* ((date (http-date-string))
238 (signature (sign-string (secret-key *credentials*)
239 date)))
240 (parameters-alist :date date
241 :authorization
242 (format nil "AWS ~A:~A"
243 (access-key *credentials*)
244 signature)
245 :if-match (and distribution (etag distribution)))))
248 (defun distribution-request (&key distribution (method :get)
249 parameters url-suffix content
250 ((:credentials *credentials*) *credentials*))
251 (let ((url (format nil "~A~@[~A~]" *cloudfront-base-url* url-suffix)))
252 (multiple-value-bind (content code headers uri stream must-close-p phrase)
253 (drakma:http-request url
254 :method method
255 :parameters parameters
256 :content-length t
257 :keep-alive nil
258 :want-stream nil
259 :content-type "text/xml"
260 :additional-headers (distribution-request-headers distribution)
261 :content
262 (or content
263 (and distribution
264 (member method '(:post :put))
265 (distribution-document distribution))))
266 (declare (ignore uri must-close-p))
267 (ignore-errors (close stream))
268 (maybe-signal-distribution-error code content)
269 (values content headers code phrase))))
271 (defbinder distribution-config
272 ("DistributionConfig"
273 ("Origin" (bind :origin))
274 ("CallerReference" (bind :caller-reference))
275 (sequence :cnames
276 ("CNAME" (bind :cname)))
277 (optional ("Comment" (bind :comment)))
278 ("Enabled" (bind :enabled))
279 (optional
280 ("Logging"
281 ("Bucket" (bind :logging-bucket))
282 ("Prefix" (bind :logging-prefix))))
283 (optional
284 ("DefaultRootObject" (bind :default-root-object)))))
286 (defbinder distribution
287 ("Distribution"
288 ("Id" (bind :id))
289 ("Status" (bind :status))
290 ("LastModifiedTime" (bind :last-modified-time))
291 ("InProgressInvalidationBatches" (bind :in-progress-invalidation-batches))
292 ("DomainName" (bind :domain-name))
293 (include distribution-config)))
295 (defun bindings-distribution (bindings)
296 (let ((timestamp (bvalue :last-modified-time bindings)))
297 (make-instance 'distribution
298 :id (bvalue :id bindings)
299 :status (bvalue :status bindings)
300 :caller-reference (bvalue :caller-reference bindings)
301 :domain-name (bvalue :domain-name bindings)
302 :origin-bucket (bvalue :origin bindings)
303 :cnames (mapcar (lambda (b) (bvalue :cname b))
304 (bvalue :cnames bindings))
305 :comment (bvalue :comment bindings)
306 :logging-bucket (bvalue :logging-bucket bindings)
307 :logging-prefix (bvalue :logging-prefix bindings)
308 :default-root-object (bvalue :default-root-object bindings)
309 :enabledp (equal (bvalue :enabled bindings) "true")
310 :last-modified (and timestamp
311 (parse-amazon-timestamp timestamp)))))
313 ;;; Distribution queries, creation, and manipulation
315 (defun put-config (distribution)
316 "Post DISTRIBUTION's configuration to AWS. Signals an error and does
317 not retry in the event of an etag match problem."
318 (multiple-value-bind (document headers code)
319 (distribution-request :distribution distribution
320 :url-suffix (format nil "/~A/config"
321 (id distribution))
322 :method :put)
323 (declare (ignore document headers))
324 (<= 200 code 299)))
326 (defun latest-version (distribution)
327 (multiple-value-bind (document headers)
328 (distribution-request :url-suffix (format nil "/~A" (id distribution)))
329 (let ((new (bindings-distribution (xml-bind 'distribution
330 document))))
331 (setf (etag new) (bvalue :etag headers))
332 new)))
334 (defun merge-into (distribution new)
335 "Copy slot values from NEW into DISTRIBUTION."
336 (macrolet ((sync (accessor)
337 `(setf (,accessor distribution) (,accessor new))))
338 (sync origin-bucket)
339 (sync caller-reference)
340 (sync etag)
341 (sync enabledp)
342 (sync cnames)
343 (sync comment)
344 (sync default-root-object)
345 (sync logging-bucket)
346 (sync logging-prefix)
347 (sync domain-name)
348 (sync status)
349 (sync last-modified))
350 distribution)
352 (defgeneric refresh (distribution)
353 (:documentation
354 "Pull down the latest data from AWS for DISTRIBUTION and update its slots.")
355 (:method ((distribution distribution))
356 (merge-into distribution (latest-version distribution))))
358 (defun call-with-latest (fun distribution)
359 "Call FUN on DISTRIBUTION; if there is an ETag-related error,
360 retries after REFRESHing DISTRIBUTION. FUN should not have side
361 effects on anything but the DISTRIBUTION itself, as it may be re-tried
362 multiple times."
363 (block nil
364 (tagbody
365 retry
366 (handler-bind
367 (((or invalid-if-match-version distribution-precondition-failed)
368 (lambda (c)
369 (declare (ignore c))
370 (setf distribution (refresh distribution))
371 (go retry))))
372 (return (funcall fun distribution))))))
374 (defun modify-and-save (fun distribution)
375 "Call the modification function FUN with DISTRIBUTION as its only
376 argument, and push the modified configuration to Cloudfront. May
377 refresh DISTRIBUTION if needed. FUN should not have side effects on
378 anything but the DISTRIBUTION itself, as it may be re-tried multiple
379 times."
380 (call-with-latest (lambda (distribution)
381 (multiple-value-prog1
382 (funcall fun distribution)
383 (put-config distribution)))
384 distribution))
386 (defmacro with-saved-modifications ((var distribution) &body body)
387 "Make a series of changes to DISTRIBUTION and push the final result
388 to AWS. BODY should not have side-effects on anything but the
389 DISTRIBUTION itself, as it may be re-tried multiple times."
390 `(modify-and-save (lambda (,var)
391 ,@body)
392 ,distribution))
394 (defbinder distribution-list
395 ("DistributionList"
396 ("Marker" (bind :marker))
397 (optional
398 ("NextMarker" (bind :next-marker)))
399 ("MaxItems" (bind :max-items))
400 ("IsTruncated" (bind :is-truncateD))
401 (sequence :distributions
402 ("DistributionSummary"
403 ("Id" (bind :id))
404 ("Status" (bind :status))
405 ("LastModifiedTime" (bind :last-modified-time))
406 ("DomainName" (bind :domain-name))
407 ("Origin" (bind :origin))
408 (sequence :cnames ("CNAME" (bind :cname)))
409 (optional ("Comment" (bind :comment)))
410 ("Enabled" (bind :enabled))))))
412 (defun all-distributions (&key ((:credentials *credentials*) *credentials*))
413 (let* ((document (distribution-request))
414 (bindings (xml-bind 'distribution-list document)))
415 (mapcar (lambda (b)
416 (bindings-distribution b))
417 (bvalue :distributions bindings))))
419 (defun create-distribution (bucket-name &key cnames (enabled t) comment)
420 (unless (listp cnames)
421 (setf cnames (list cnames)))
422 (let ((distribution (make-instance 'distribution
423 :origin-bucket bucket-name
424 :enabledp enabled
425 :comment comment
426 :cnames cnames)))
427 (let* ((document (distribution-request :method :post
428 :distribution distribution))
429 (bindings (xml-bind 'distribution document)))
430 (bindings-distribution bindings))))
432 (defun %delete-distribution (distribution)
433 (multiple-value-bind (document headers code)
434 (distribution-request :url-suffix (format nil "/~A" (id distribution))
435 :distribution distribution
436 :method :delete)
437 (declare (ignore document headers))
438 (= code 204)))
440 (defgeneric delete-distribution (distribution)
441 (:method ((distribution distribution))
442 (call-with-latest #'%delete-distribution distribution)))
444 (defgeneric enable (distribution)
445 (:documentation
446 "Mark DISTRIBUTION as enabled. Enabling can take time to take
447 effect; the STATUS of DISTRIBUTION will change from \"InProgress\"
448 to \"Deployed\" when fully enabled.")
449 (:method ((distribution distribution))
450 (with-saved-modifications (d distribution)
451 (setf (enabledp d) t))))
454 (defgeneric disable (distribution)
455 (:documentation
456 "Mark DISTRIBUTION as disabled. Like ENABLE, DISABLE may take some
457 time to take effect.")
458 (:method ((distribution distribution))
459 (with-saved-modifications (d distribution)
460 (setf (enabledp d) nil)
461 t)))
463 (defgeneric ensure-cname (distribution cname)
464 (:documentation
465 "Add CNAME to DISTRIBUTION's list of CNAMEs, if not already
466 present.")
467 (:method ((distribution distribution) cname)
468 (with-saved-modifications (d distribution)
469 (pushnew cname (cnames d)
470 :test #'string-equal))))
472 (defgeneric remove-cname (distribution cname)
473 (:method (cname (distribution distribution))
474 (with-saved-modifications (d distribution)
475 (setf (cnames d)
476 (remove cname (cnames distribution)
477 :test #'string-equal)))))
479 (defgeneric set-comment (distribution comment)
480 (:method ((distribution distribution) comment)
481 (with-saved-modifications (d distribution)
482 (setf (comment d) comment))))
484 (defun distributions-for-bucket (bucket-name)
485 "Return a list of distributions that are associated with BUCKET-NAME."
486 (setf bucket-name (canonical-distribution-bucket-name bucket-name))
487 (remove bucket-name
488 (all-distributions)
489 :test-not #'string-equal
490 :key #'origin-bucket))
493 ;;; Invalidation
495 (defclass invalidation ()
496 ((id
497 :initarg :id
498 :accessor id
499 :initform "*unset*"
500 :documentation "Amazon's assigned unique ID.")
501 (distribution
502 :initarg :distribution
503 :accessor distribution
504 :initform nil)
505 (create-time
506 :initarg :create-time
507 :initform 0
508 :accessor create-time)
509 (status
510 :initarg :status
511 :accessor status
512 :initform "InProgress")
513 (caller-reference
514 :initarg :caller-reference
515 :initform (generate-caller-reference)
516 :accessor caller-reference)
517 (paths
518 :initarg :paths
519 :accessor paths
520 :initform '())))
522 (defmethod print-object ((invalidation invalidation) stream)
523 (print-unreadable-object (invalidation stream :type t)
524 (format stream "~S [~A]"
525 (id invalidation)
526 (status invalidation))))
529 (defbinder invalidation-batch
530 ("InvalidationBatch"
531 (sequence :paths ("Path" (bind :path)))
532 ("CallerReference" (bind :caller-reference))))
534 (defbinder invalidation
535 ("Invalidation"
536 ("Id" (bind :id))
537 ("Status" (bind :status))
538 ("CreateTime" (bind :create-time))
539 (include invalidation-batch)))
541 (defmethod merge-bindings ((invalidation invalidation) bindings)
542 (setf (id invalidation) (bvalue :id bindings)
543 (status invalidation) (bvalue :status bindings)
544 (create-time invalidation) (parse-amazon-timestamp
545 (bvalue :create-time bindings))
546 (paths invalidation)
547 (mapcar #'url-decode
548 (mapcar (bfun :path) (bvalue :paths bindings))))
549 invalidation)
551 (defgeneric distribution-id (object)
552 (:method ((invalidation invalidation))
553 (id (distribution invalidation))))
555 (defun invalidation-request (invalidation &key (url-suffix "")
556 (method :get) content)
557 (distribution-request :method method
558 :url-suffix (format nil "/~A/invalidation~A"
559 (distribution-id invalidation)
560 url-suffix)
561 :content content))
563 (defun invalidation-batch-document (invalidation)
564 (with-xml-output
565 (with-element "InvalidationBatch"
566 (attribute "xmlns" "http://cloudfront.amazonaws.com/doc/2010-08-01/")
567 (dolist (path (paths invalidation))
568 (with-element "Path"
569 (text path)))
570 (with-element "CallerReference"
571 (text (caller-reference invalidation))))))
574 (defun invalidate-paths (distribution paths)
575 (let* ((invalidation (make-instance 'invalidation
576 :distribution distribution
577 :paths paths))
578 (response
579 (invalidation-request invalidation
580 :method :post
581 :content (invalidation-batch-document invalidation))))
582 (merge-bindings invalidation (xml-bind 'invalidation response))))
585 (defmethod refresh ((invalidation invalidation))
586 (let ((document
587 (invalidation-request invalidation
588 :url-suffix (format nil "/~A"
589 (id invalidation)))))
590 (merge-bindings invalidation (xml-bind 'invalidation document))))