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 (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))))
  56
  57 (define-condition distribution-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)))))
  78
  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) ())))
  84
  85 (define-specific-distribution-error "InvalidIfMatchVersion"
  86     invalid-if-match-version)
  87
  88 (define-specific-distribution-error "PreconditionFailed"
  89     distribution-precondition-failed)
  90
  91 (define-specific-distribution-error "DistributionNotDisabled"
  92     distribution-not-disabled)
  93
  94 (define-specific-distribution-error "CNAMEAlreadyExists"
  95     cname-already-exists)
  96
  97 (define-specific-distribution-error "TooManyDistributions"
  98     too-many-distributions)
  99
 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)))))
 115
 116
 117 ;;; Distribution objects
 118
 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*)))
 123
 124 (defun generate-caller-reference ()
 125   (format nil "~D.~D"
 126           (get-universal-time)
 127           (incf *caller-reference-counter*)))
 128
 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)
 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   (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))))))))
 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 (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)))))
 285
 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)))
 294
 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)))))
 312
 313 ;;; Distribution queries, creation, and manipulation
 314
 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)))
 325
 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)))
 333
 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)
 351
 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))))
 357
 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))))))
 373
 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))
 385
 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))
 393
 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))))))
 411
 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))))
 418
 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))))
 431
 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)))
 439
 440 (defgeneric delete-distribution (distribution)
 441   (:method ((distribution distribution))
 442     (call-with-latest #'%delete-distribution distribution)))
 443
 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))))
 452
 453
 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)))
 462
 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))))
 471
 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)))))
 478
 479 (defgeneric set-comment (distribution comment)
 480   (:method ((distribution distribution) comment)
 481     (with-saved-modifications (d distribution)
 482       (setf (comment d) comment))))
 483
 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))
 491
 492
 493 ;;; Invalidation
 494
 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 '())))
 521
 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))))
 527
 528
 529 (defbinder invalidation-batch
 530   ("InvalidationBatch"
 531    (sequence :paths ("Path" (bind :path)))
 532    ("CallerReference" (bind :caller-reference))))
 533
 534 (defbinder invalidation
 535   ("Invalidation"
 536    ("Id" (bind :id))
 537    ("Status" (bind :status))
 538    ("CreateTime" (bind :create-time))
 539    (include invalidation-batch)))
 540
 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)
 550
 551 (defgeneric distribution-id (object)
 552   (:method ((invalidation invalidation))
 553     (id (distribution invalidation))))
 554
 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))
 562
 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))))))
 572
 573
 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))))
 583
 584
 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))))