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    (default-root-object
 153     :initarg :default-root-object
 154     :accessor default-root-object)
 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)
 167    (id
 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.")))
 190
 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))))
 197
 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))))
 204
 205
 206 ;;; Distribution-related requests
 207
 208 (defun distribution-document (distribution)
 209   (cxml:with-xml-output (cxml:make-string-sink)
 210     (cxml:with-element "DistributionConfig"
 211       (cxml:attribute "xmlns" "http://cloudfront.amazonaws.com/doc/2010-08-01/")
 212       (cxml:with-element "Origin"
 213         (cxml:text (origin-bucket distribution)))
 214       (cxml:with-element "CallerReference"
 215         (cxml:text (caller-reference distribution)))
 216       (dolist (cname (cnames distribution))
 217         (cxml:with-element "CNAME"
 218           (cxml:text cname)))
 219       (when (comment distribution)
 220         (cxml:with-element "Comment"
 221           (cxml:text (comment distribution))))
 222       (cxml:with-element "Enabled"
 223         (cxml:text (if (enabledp distribution)
 224                        "true"
 225                        "false")))
 226       (cxml:with-element "DefaultRootObject"
 227         (when (default-root-object distribution)
 228           (cxml: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           (cxml:with-element "Logging"
 233             (cxml:with-element "Bucket" (cxml:text logging-bucket))
 234             (cxml:with-element "Prefix" (cxml:text logging-prefix))))))))
 235
 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)))))
 246
 247
 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))))
 270
 271 (defparameter *distribution-config-form*
 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)))))
 285
 286 (defparameter *distribution-form*
 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     ,@*distribution-config-form*))
 294
 295 (defparameter *distribution-config-binder*
 296   (make-binder *distribution-config-form*))
 297
 298 (defparameter *distribution-binder* (make-binder *distribution-form*))
 299
 300 (defun bindings-distribution (bindings)
 301   (let ((timestamp (bvalue :last-modified-time bindings)))
 302     (make-instance 'distribution
 303                    :id (bvalue :id bindings)
 304                    :status (bvalue :status bindings)
 305                    :caller-reference (bvalue :caller-reference bindings)
 306                    :domain-name (bvalue :domain-name bindings)
 307                    :origin-bucket (bvalue :origin bindings)
 308                    :cnames (mapcar (lambda (b) (bvalue :cname b))
 309                                    (bvalue :cnames bindings))
 310                    :comment (bvalue :comment bindings)
 311                    :logging-bucket (bvalue :logging-bucket bindings)
 312                    :logging-prefix (bvalue :logging-prefix bindings)
 313                    :default-root-object (bvalue :default-root-object bindings)
 314                    :enabledp (equal (bvalue :enabled bindings) "true")
 315                    :last-modified (and timestamp
 316                                        (parse-amazon-timestamp timestamp)))))
 317
 318 ;;; Distribution queries, creation, and manipulation
 319
 320 (defun put-config (distribution)
 321   "Post DISTRIBUTION's configuration to AWS. Signals an error and does
 322 not retry in the event of an etag match problem."
 323   (multiple-value-bind (document headers code)
 324       (distribution-request :distribution distribution
 325                             :url-suffix (format nil "/~A/config"
 326                                                 (id distribution))
 327                             :method :put)
 328     (declare (ignore document headers))
 329     (<= 200 code 299)))
 330
 331 (defun latest-version (distribution)
 332   (multiple-value-bind (document headers)
 333       (distribution-request :url-suffix (format nil "/~A" (id distribution)))
 334     (let ((new (bindings-distribution (xml-bind *distribution-binder*
 335                                                 document))))
 336       (setf (etag new) (bvalue :etag headers))
 337       new)))
 338
 339 (defun merge-into (distribution new)
 340   "Copy slot values from NEW into DISTRIBUTION."
 341   (macrolet ((sync (accessor)
 342                `(setf (,accessor distribution) (,accessor new))))
 343     (sync origin-bucket)
 344     (sync caller-reference)
 345     (sync etag)
 346     (sync enabledp)
 347     (sync cnames)
 348     (sync comment)
 349     (sync default-root-object)
 350     (sync logging-bucket)
 351     (sync logging-prefix)
 352     (sync domain-name)
 353     (sync status)
 354     (sync last-modified))
 355   distribution)
 356
 357 (defgeneric refresh (distribution)
 358   (:documentation
 359    "Pull down the latest data from AWS for DISTRIBUTION and update its slots.")
 360   (:method ((distribution distribution))
 361     (merge-into distribution (latest-version distribution))))
 362
 363 (defun call-with-latest (fun distribution)
 364   "Call FUN on DISTRIBUTION; if there is an ETag-related error,
 365 retries after REFRESHing DISTRIBUTION. FUN should not have side
 366 effects on anything but the DISTRIBUTION itself, as it may be re-tried
 367 multiple times."
 368   (block nil
 369     (tagbody
 370      retry
 371        (handler-bind
 372            (((or invalid-if-match-version distribution-precondition-failed)
 373              (lambda (c)
 374                (declare (ignore c))
 375                (setf distribution (refresh distribution))
 376                (go retry))))
 377          (return (funcall fun distribution))))))
 378
 379 (defun modify-and-save (fun distribution)
 380   "Call the modification function FUN with DISTRIBUTION as its only
 381 argument, and push the modified configuration to Cloudfront. May
 382 refresh DISTRIBUTION if needed. FUN should not have side effects on
 383 anything but the DISTRIBUTION itself, as it may be re-tried multiple
 384 times."
 385   (call-with-latest (lambda (distribution)
 386                       (multiple-value-prog1
 387                           (funcall fun distribution)
 388                         (put-config distribution)))
 389                     distribution))
 390
 391 (defmacro with-saved-modifications ((var distribution) &body body)
 392   "Make a series of changes to DISTRIBUTION and push the final result
 393 to AWS. BODY should not have side-effects on anything but the
 394 DISTRIBUTION itself, as it may be re-tried multiple times."
 395   `(modify-and-save (lambda (,var)
 396                       ,@body)
 397     ,distribution))
 398
 399 (defparameter *distribution-list-binder*
 400   (make-binder
 401    '("DistributionList"
 402      ("Marker" (bind :marker))
 403      (optional
 404       ("NextMarker" (bind :next-marker)))
 405      ("MaxItems" (bind :max-items))
 406      ("IsTruncated" (bind :is-truncateD))
 407      (sequence :distributions
 408       ("DistributionSummary"
 409        ("Id" (bind :id))
 410        ("Status" (bind :status))
 411        ("LastModifiedTime" (bind :last-modified-time))
 412        ("DomainName" (bind :domain-name))
 413        ("Origin" (bind :origin))
 414        (sequence :cnames ("CNAME" (bind :cname)))
 415        (optional ("Comment" (bind :comment)))
 416        ("Enabled" (bind :enabled)))))))
 417
 418 (defun all-distributions (&key ((:credentials *credentials*) *credentials*))
 419   (let* ((document (distribution-request))
 420          (bindings (xml-bind *distribution-list-binder* document)))
 421     (mapcar (lambda (b)
 422               (bindings-distribution b))
 423             (bvalue :distributions bindings))))
 424
 425 (defun create-distribution (bucket-name &key cnames (enabled t) comment)
 426   (unless (listp cnames)
 427     (setf cnames (list cnames)))
 428   (let ((distribution (make-instance 'distribution
 429                                      :origin-bucket bucket-name
 430                                      :enabledp enabled
 431                                      :comment comment
 432                                      :cnames cnames)))
 433     (let* ((document (distribution-request :method :post
 434                                            :distribution distribution))
 435            (bindings (xml-bind *distribution-binder* document)))
 436       (bindings-distribution bindings))))
 437
 438 (defun %delete-distribution (distribution)
 439   (multiple-value-bind (document headers code)
 440       (distribution-request :url-suffix (format nil "/~A" (id distribution))
 441                             :distribution distribution
 442                             :method :delete)
 443     (declare (ignore document headers))
 444     (= code 204)))
 445
 446 (defgeneric delete-distribution (distribution)
 447   (:method ((distribution distribution))
 448     (call-with-latest #'%delete-distribution distribution)))
 449
 450 (defgeneric enable (distribution)
 451   (:documentation
 452    "Mark DISTRIBUTION as enabled. Enabling can take time to take
 453    effect; the STATUS of DISTRIBUTION will change from \"InProgress\"
 454    to \"Deployed\" when fully enabled.")
 455   (:method ((distribution distribution))
 456     (with-saved-modifications (d distribution)
 457       (setf (enabledp d) t))))
 458
 459
 460 (defgeneric disable (distribution)
 461   (:documentation
 462    "Mark DISTRIBUTION as disabled. Like ENABLE, DISABLE may take some
 463    time to take effect.")
 464   (:method ((distribution distribution))
 465     (with-saved-modifications (d distribution)
 466       (setf (enabledp d) nil)
 467       t)))
 468
 469 (defgeneric ensure-cname (distribution cname)
 470   (:documentation
 471    "Add CNAME to DISTRIBUTION's list of CNAMEs, if not already
 472    present.")
 473   (:method ((distribution distribution) cname)
 474     (with-saved-modifications (d distribution)
 475       (pushnew cname (cnames d)
 476                :test #'string-equal))))
 477
 478 (defgeneric remove-cname (distribution cname)
 479   (:method (cname (distribution distribution))
 480     (with-saved-modifications (d distribution)
 481       (setf (cnames d)
 482             (remove cname (cnames distribution)
 483                     :test #'string-equal)))))
 484
 485 (defgeneric set-comment (distribution comment)
 486   (:method ((distribution distribution) comment)
 487     (with-saved-modifications (d distribution)
 488       (setf (comment d) comment))))
 489
 490 (defun distributions-for-bucket (bucket-name)
 491   "Return a list of distributions that are associated with BUCKET-NAME."
 492   (setf bucket-name (canonical-distribution-bucket-name bucket-name))
 493   (remove bucket-name
 494           (all-distributions)
 495           :test-not #'string-equal
 496           :key #'origin-bucket))
 497
 498
 499 ;;; Invalidation
 500
 501 (defclass invalidation ()
 502   ((id
 503     :initarg :id
 504     :accessor id
 505     :initform "*unset*"
 506     :documentation "Amazon's assigned unique ID.")
 507    (distribution
 508     :initarg :distribution
 509     :accessor distribution
 510     :initform nil)
 511    (create-time
 512     :initarg :create-time
 513     :initform 0
 514     :accessor create-time)
 515    (status
 516     :initarg :status
 517     :accessor status
 518     :initform "InProgress")
 519    (caller-reference
 520     :initarg :caller-reference
 521     :initform (generate-caller-reference)
 522     :accessor caller-reference)
 523    (paths
 524     :initarg :paths
 525     :accessor paths
 526     :initform '())))
 527
 528 (defmethod print-object ((invalidation invalidation) stream)
 529   (print-unreadable-object (invalidation stream :type t)
 530     (format stream "~S [~A]"
 531             (id invalidation)
 532             (status invalidation))))
 533
 534 (defparameter *invalidation-batch-form*
 535   '("InvalidationBatch"
 536     (sequence :paths ("Path" (bind :path)))
 537     ("CallerReference" (bind :caller-reference))))
 538
 539 (defparameter *invalidation-form*
 540   `("Invalidation"
 541     ("Id" (bind :id))
 542     ("Status" (bind :status))
 543     ("CreateTime" (bind :create-time))
 544     ,*invalidation-batch-form*))
 545
 546 (defparameter *invalidation-batch-binder*
 547   (make-binder *invalidation-batch-form*))
 548
 549 (defparameter *invalidation-binder*
 550   (make-binder *invalidation-form*))
 551
 552 (defmethod merge-bindings ((invalidation invalidation) bindings)
 553   (setf (id invalidation) (bvalue :id bindings)
 554         (status invalidation) (bvalue :status bindings)
 555         (create-time invalidation) (parse-amazon-timestamp
 556                                     (bvalue :create-time bindings))
 557         (paths invalidation)
 558         (mapcar #'url-decode
 559                 (mapcar (bfun :path) (bvalue :paths bindings))))
 560   invalidation)
 561
 562 (defgeneric distribution-id (object)
 563   (:method ((invalidation invalidation))
 564     (id (distribution invalidation))))
 565
 566 (defun invalidation-request (invalidation &key (url-suffix "")
 567                              (method :get) content)
 568   (distribution-request :method method
 569                         :url-suffix (format nil "/~A/invalidation~A"
 570                                             (distribution-id invalidation)
 571                                             url-suffix)
 572                         :content content))
 573
 574 (defun invalidation-batch-document (invalidation)
 575   (cxml:with-xml-output (cxml:make-string-sink)
 576     (cxml:with-element "InvalidationBatch"
 577       (cxml:attribute "xmlns" "http://cloudfront.amazonaws.com/doc/2010-08-01/")
 578       (dolist (path (paths invalidation))
 579         (cxml:with-element "Path"
 580           (cxml:text path)))
 581       (cxml:with-element "CallerReference"
 582         (cxml:text (caller-reference invalidation))))))
 583
 584
 585 (defun invalidate-paths (distribution paths)
 586   (let* ((invalidation (make-instance 'invalidation
 587                                       :distribution distribution
 588                                       :paths paths))
 589          (response
 590           (invalidation-request invalidation
 591                                 :method :post
 592                                 :content (invalidation-batch-document invalidation))))
 593     (merge-bindings invalidation (xml-bind *invalidation-binder* response))))
 594
 595
 596 (defmethod refresh ((invalidation invalidation))
 597   (let ((document
 598          (invalidation-request invalidation
 599                                :url-suffix (format nil "/~A"
 600                                                    (id invalidation)))))
 601     (merge-bindings invalidation (xml-bind *invalidation-binder* document))))