cloudfront.lisp

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