interface.lisp

   1 ;;;;
   2 ;;;; Copyright (c) 2008, 2015 Zachary Beane, All Rights Reserved
   3 ;;;;
   4 ;;;; Redistribution and use in source and binary forms, with or without
   5 ;;;; modification, are permitted provided that the following conditions
   6 ;;;; are met:
   7 ;;;;
   8 ;;;;   * Redistributions of source code must retain the above copyright
   9 ;;;;     notice, this list of conditions and the following disclaimer.
  10 ;;;;
  11 ;;;;   * Redistributions in binary form must reproduce the above
  12 ;;;;     copyright notice, this list of conditions and the following
  13 ;;;;     disclaimer in the documentation and/or other materials
  14 ;;;;     provided with the distribution.
  15 ;;;;
  16 ;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  17 ;;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  18 ;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  19 ;;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  20 ;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  21 ;;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  22 ;;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  23 ;;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  24 ;;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  25 ;;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  26 ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  27 ;;;;
  28 ;;;; interface.lisp
  29
  30 (in-package #:zs3)
  31
  32 (defparameter *canned-access-policies*
  33   '((:private . "private")
  34     (:public-read . "public-read")
  35     (:public-read-write . "public-read-write")
  36     (:authenticated-read . "authenticated-read")))
  37
  38 (defun canned-access-policy (access-policy)
  39   (let ((value (assoc access-policy *canned-access-policies*)))
  40     (unless value
  41       (error "~S is not a supported access policy.~%Supported policies are ~S"
  42              access-policy
  43              (mapcar 'first *canned-access-policies*)))
  44     (list (cons "acl" (cdr value)))))
  45
  46 (defun access-policy-header (access-policy public)
  47   (cond ((and access-policy public)
  48          (error "Only one of ~S and ~S should be provided"
  49                 :public :access-policy))
  50         (public
  51          (canned-access-policy :public-read))
  52         (access-policy
  53          (canned-access-policy access-policy))))
  54
  55 (defun head (&key bucket key parameters
  56                ((:credentials *credentials*) *credentials*)
  57                ((:backoff *backoff*) *backoff*))
  58   "Return three values: the HTTP status, an alist of Drakma-style HTTP
  59 headers, and the HTTP phrase, with the results of a HEAD request for
  60 the object specified by the optional BUCKET and KEY arguments."
  61   (let* ((security-token (security-token *credentials*))
  62          (response
  63           (submit-request (make-instance 'request
  64                                          :method :head
  65                                          :bucket bucket
  66                                          :key key
  67                                          :amz-headers
  68                                          (when security-token
  69                                            (list (cons "security-token" security-token)))
  70                                          :parameters parameters))))
  71
  72     (values (http-headers response)
  73             (http-code response)
  74             (http-phrase response))))
  75
  76 ;;; Operations on buckets
  77
  78 (defun all-buckets (&key ((:credentials *credentials*) *credentials*)
  79                       ((:backoff *backoff*) *backoff*))
  80   "Return a vector of all BUCKET objects associated with *CREDENTIALS*."
  81   (let ((response (submit-request (make-instance 'request
  82                                                  :method :get))))
  83     (buckets response)))
  84
  85 (defun bucket-location (bucket &key
  86                                  ((:credentials *credentials*) *credentials*)
  87                                  ((:backoff *backoff*) *backoff*))
  88   "If BUCKET was created with a LocationConstraint, return its
  89 constraint."
  90   (let* ((request (make-instance 'request
  91                                   :method :get
  92                                   :sub-resource "location"
  93                                   :extra-http-headers
  94                                   `(,(when (security-token *credentials*)
  95                                        (cons "x-amz-security-token"
  96                                              (security-token *credentials*))))
  97                                   :bucket bucket))
  98          (response (submit-request request))
  99          (location (location response)))
 100     (when (plusp (length location))
 101       location)))
 102
 103 (defun bucket-region (bucket
 104                       &key ((:credentials *credentials*) *credentials*)
 105                         ((:backoff *backoff*) *backoff*))
 106   (or (bucket-location bucket)
 107       "us-east-1"))
 108
 109 (defun region-endpoint (region)
 110   (if (string= region "us-east-1")
 111       "s3.amazonaws.com"
 112       (format nil "s3-~A.amazonaws.com" region)))
 113
 114 (defun query-bucket (bucket &key prefix marker max-keys delimiter
 115                               ((:credentials *credentials*) *credentials*)
 116                               ((:backoff *backoff*) *backoff*))
 117   (submit-request (make-instance 'request
 118                                  :method :get
 119                                  :bucket bucket
 120                                  :parameters
 121                                  (parameters-alist
 122                                   :prefix prefix
 123                                   :marker marker
 124                                   :max-keys max-keys
 125                                   :delimiter delimiter))))
 126
 127 (defun continue-bucket-query (response)
 128   (when response
 129     (let ((request (successive-request response)))
 130       (when request
 131         (submit-request request)))))
 132
 133 (defun all-keys (bucket &key prefix
 134                           ((:credentials *credentials*) *credentials*)
 135                           ((:backoff *backoff*) *backoff*))
 136   "Reutrn a vector of all KEY objects in BUCKET."
 137   (let ((response (query-bucket bucket :prefix prefix))
 138         (results '()))
 139     (loop
 140      (unless response
 141        (return))
 142      (push (keys response) results)
 143      (setf response (continue-bucket-query response)))
 144     (let ((combined (make-array (reduce #'+ results :key #'length)))
 145           (start 0))
 146       (dolist (keys (nreverse results) combined)
 147         (replace combined keys :start1 start)
 148         (incf start (length keys))))))
 149
 150 (defun bucket-exists-p (bucket &key
 151                                  ((:credentials *credentials*) *credentials*)
 152                                  ((:backoff *backoff*) *backoff*))
 153   (let ((code (nth-value 1 (head :bucket bucket
 154                                  :parameters
 155                                  (parameters-alist :max-keys 0)))))
 156     (not (<= 400 code 599))))
 157
 158 (defun create-bucket (name &key
 159                       access-policy
 160                       public
 161                       location
 162                              ((:credentials *credentials*) *credentials*)
 163                              ((:backoff *backoff*) *backoff*))
 164   (let ((policy-header (access-policy-header access-policy public)))
 165     (submit-request (make-instance 'request
 166                                    :method :put
 167                                    :bucket name
 168                                    :content (and location
 169                                                  (location-constraint-xml
 170                                                   location))
 171                                    :amz-headers policy-header))))
 172
 173 (defun delete-bucket (bucket &key
 174                                ((:credentials *credentials*) *credentials*)
 175                                ((:backoff *backoff*) *backoff*))
 176   (let* ((request (make-instance 'request
 177                                  :method :delete
 178                                  :bucket bucket))
 179          (endpoint (endpoint request))
 180          (bucket (bucket request)))
 181     (prog1
 182         (submit-request request)
 183       (setf (redirection-data endpoint bucket) nil))))
 184
 185
 186 ;;; Getting objects as vectors, strings, or files
 187
 188 (defun check-request-success (response)
 189   (let ((code (http-code response)))
 190     (cond ((= code 304)
 191            (throw 'not-modified (values nil (http-headers response))))
 192           ((not (<= 200 code 299))
 193            (setf response (specialize-response response))
 194            (maybe-signal-error response)))))
 195
 196 (defun make-file-writer-handler (file &key (if-exists :supersede))
 197   (lambda (response)
 198     (check-request-success response)
 199     (let ((input (body response)))
 200       (with-open-file (output file :direction :output
 201                                    :if-exists if-exists
 202                                    :element-type '(unsigned-byte 8))
 203         (copy-n-octets (content-length response) input output)))
 204     (setf (body response) (probe-file file))
 205     response))
 206
 207 (defun vector-writer-handler (response)
 208   (check-request-success response)
 209   (let ((buffer (make-octet-vector (content-length response))))
 210     (setf (body response)
 211           (let ((input (body response)))
 212             (read-sequence buffer input)
 213             buffer))
 214     response))
 215
 216 (defun stream-identity-handler (response)
 217   (check-request-success response)
 218   response)
 219
 220 (defun make-string-writer-handler (external-format)
 221   (lambda (response)
 222     (setf response (vector-writer-handler response))
 223     (setf (body response)
 224           (flexi-streams:octets-to-string (body response)
 225                                     :external-format external-format))
 226     response))
 227
 228
 229
 230 (defun get-object (bucket key &key
 231                                 when-modified-since
 232                                 unless-modified-since
 233                                 when-etag-matches
 234                                 unless-etag-matches
 235                                 start end
 236                                 (output :vector)
 237                                 (if-exists :supersede)
 238                                 (string-external-format :utf-8)
 239                                 ((:credentials *credentials*) *credentials*)
 240                                 ((:backoff *backoff*) *backoff*))
 241   (flet ((range-argument (start end)
 242            (when start
 243              (format nil "bytes=~D-~@[~D~]" start (and end (1- end)))))
 244          (maybe-date (time)
 245            (and time (http-date-string time))))
 246     (when (and end (not start))
 247       (setf start 0))
 248     (when (and start end (<= end start))
 249       (error "START must be less than END."))
 250     (let* ((security-token (security-token *credentials*))
 251            (request (make-instance 'request
 252                                    :method :get
 253                                    :bucket bucket
 254                                    :key key
 255                                    :amz-headers
 256                                    (when security-token
 257                                      (list (cons "security-token" security-token)))
 258                                    :extra-http-headers
 259                                    (parameters-alist
 260                                     ;; nlevine 2016-06-15 -- not only is this apparently
 261                                     ;; unnecessary, it also sends "connection" in the
 262                                     ;; signed headers, which results in a
 263                                     ;; SignatureDoesNotMatch error.
 264                                     ;;  :connection (unless *use-keep-alive* "close")
 265                                     :if-modified-since
 266                                     (maybe-date when-modified-since)
 267                                     :if-unmodified-since
 268                                     (maybe-date unless-modified-since)
 269                                     :if-match when-etag-matches
 270                                     :if-none-match unless-etag-matches
 271                                     :range (range-argument start end))))
 272            (handler (cond ((eql output :vector)
 273                            'vector-writer-handler)
 274                           ((eql output :string)
 275                            (make-string-writer-handler string-external-format))
 276                           ((eql output :stream)
 277                            'stream-identity-handler)
 278                           ((or (stringp output)
 279                                (pathnamep output))
 280                            (make-file-writer-handler output :if-exists if-exists))
 281                           (t
 282                            (error "Unknown ~S option ~S -- should be ~
 283                                   :VECTOR, :STRING, :STREAM, or a pathname"
 284                                  :output output)))))
 285       (catch 'not-modified
 286         (handler-case
 287             (let ((response (submit-request request
 288                                             :keep-stream (or (eql output :stream)
 289                                                              *use-keep-alive*)
 290                                             :body-stream t
 291                                             :handler handler)))
 292               (values (body response) (http-headers response)))
 293           (precondition-failed (c)
 294             (throw 'not-modified
 295               (values nil
 296                       (http-headers (request-error-response c))))))))))
 297
 298 (defun get-vector (bucket key
 299                    &key start end
 300                    when-modified-since unless-modified-since
 301                    when-etag-matches unless-etag-matches
 302                    (if-exists :supersede)
 303                      ((:credentials *credentials*) *credentials*)
 304                      ((:backoff *backoff*) *backoff*))
 305   (get-object bucket key
 306               :output :vector
 307               :start start
 308               :end end
 309               :when-modified-since when-modified-since
 310               :unless-modified-since unless-modified-since
 311               :when-etag-matches when-etag-matches
 312               :unless-etag-matches unless-etag-matches
 313               :if-exists if-exists))
 314
 315 (defun get-string (bucket key
 316                    &key start end
 317                    (external-format :utf-8)
 318                    when-modified-since unless-modified-since
 319                    when-etag-matches unless-etag-matches
 320                    (if-exists :supersede)
 321                      ((:credentials *credentials*) *credentials*)
 322                      ((:backoff *backoff*) *backoff*))
 323   (get-object bucket key
 324               :output :string
 325               :string-external-format external-format
 326               :start start
 327               :end end
 328               :when-modified-since when-modified-since
 329               :unless-modified-since unless-modified-since
 330               :when-etag-matches when-etag-matches
 331               :unless-etag-matches unless-etag-matches
 332               :if-exists if-exists))
 333
 334 (defun get-file (bucket key file
 335                  &key start end
 336                  when-modified-since unless-modified-since
 337                  when-etag-matches unless-etag-matches
 338                  (if-exists :supersede)
 339                    ((:credentials *credentials*) *credentials*)
 340                    ((:backoff *backoff*) *backoff*))
 341   (get-object bucket key
 342               :output (pathname file)
 343               :start start
 344               :end end
 345               :when-modified-since when-modified-since
 346               :unless-modified-since unless-modified-since
 347               :when-etag-matches when-etag-matches
 348               :unless-etag-matches unless-etag-matches
 349               :if-exists if-exists))
 350
 351
 352 ;;; Putting objects
 353
 354 (defun format-tagging-header (tagging)
 355   (format nil "~{~a=~a~^&~}"
 356           (mapcan #'(lambda (kv)
 357                       (list
 358                        (drakma:url-encode (car kv) :iso-8859-1)
 359                        (drakma:url-encode (cdr kv) :iso-8859-1)))
 360                   tagging)))
 361
 362 (defun put-object (object bucket key &key
 363                                        access-policy
 364                                        public
 365                                        metadata
 366                                        (string-external-format :utf-8)
 367                                        cache-control
 368                                        content-encoding
 369                                        content-disposition
 370                                        expires
 371                                        content-type
 372                                        (storage-class "STANDARD")
 373                                        tagging
 374                                        ((:credentials *credentials*) *credentials*)
 375                                        ((:backoff *backoff*) *backoff*))
 376   (let ((content
 377          (etypecase object
 378            (string
 379             (flexi-streams:string-to-octets object
 380                                             :external-format
 381                                             string-external-format))
 382            ((or vector pathname) object)))
 383         (content-length t)
 384         (policy-header (access-policy-header access-policy public))
 385         (security-token (security-token *credentials*)))
 386     (setf storage-class (or storage-class "STANDARD"))
 387     (submit-request (make-instance 'request
 388                                    :method :put
 389                                    :bucket bucket
 390                                    :key key
 391                                    :metadata metadata
 392                                    :amz-headers
 393                                    (append policy-header
 394                                            (when security-token
 395                                              (list (cons "security-token" security-token)))
 396                                            (when tagging
 397                                              (list
 398                                               (cons "tagging" (format-tagging-header tagging)))))
 399                                    :extra-http-headers
 400                                    (parameters-alist
 401                                     :cache-control cache-control
 402                                     :content-encoding content-encoding
 403                                     :content-disposition content-disposition
 404                                     :expires (and expires
 405                                                   (http-date-string expires)))
 406                                    :content-type content-type
 407                                    :content-length content-length
 408                                    :content content))))
 409
 410
 411 (defun put-vector (vector bucket key &key
 412                    start end
 413                    access-policy
 414                    public
 415                    metadata
 416                    cache-control
 417                    content-encoding
 418                    content-disposition
 419                    (content-type "binary/octet-stream")
 420                    expires
 421                    storage-class
 422                    tagging
 423                    ((:credentials *credentials*) *credentials*)
 424                    ((:backoff *backoff*) *backoff*))
 425   (when (or start end)
 426     (setf vector (subseq vector (or start 0) end)))
 427   (put-object vector bucket key
 428               :access-policy access-policy
 429               :public public
 430               :metadata metadata
 431               :cache-control cache-control
 432               :content-encoding content-encoding
 433               :content-disposition content-disposition
 434               :content-type content-type
 435               :expires expires
 436               :storage-class storage-class
 437               :tagging tagging))
 438
 439 (defun put-string (string bucket key &key
 440                    start end
 441                    access-policy
 442                    public
 443                    metadata
 444                    (external-format :utf-8)
 445                    cache-control
 446                    content-encoding
 447                    content-disposition
 448                    (content-type "text/plain")
 449                    expires
 450                    storage-class
 451                    tagging
 452                    ((:credentials *credentials*) *credentials*)
 453                    ((:backoff *backoff*) *backoff*))
 454   (when (or start end)
 455     (setf string (subseq string (or start 0) end)))
 456   (put-object string bucket key
 457               :access-policy access-policy
 458               :public public
 459               :metadata metadata
 460               :expires expires
 461               :content-disposition content-disposition
 462               :content-encoding content-encoding
 463               :content-type content-type
 464               :cache-control cache-control
 465               :string-external-format external-format
 466               :storage-class storage-class
 467               :tagging tagging))
 468
 469
 470 (defun put-file (file bucket key &key
 471                  start end
 472                  access-policy
 473                  public
 474                  metadata
 475                  cache-control
 476                  content-disposition
 477                  content-encoding
 478                  (content-type "binary/octet-stream")
 479                  expires
 480                  storage-class
 481                  tagging
 482                  ((:credentials *credentials*) *credentials*)
 483                  ((:backoff *backoff*) *backoff*))
 484   (when (eq key t)
 485     (setf key (file-namestring file)))
 486   (let ((content (pathname file)))
 487     (when (or start end)
 488       ;;; FIXME: integrate with not-in-memory file uploading
 489       (setf content (file-subset-vector file start end)))
 490     (put-object content bucket key
 491                 :access-policy access-policy
 492                 :public public
 493                 :metadata metadata
 494                 :cache-control cache-control
 495                 :content-disposition content-disposition
 496                 :content-encoding content-encoding
 497                 :content-type content-type
 498                 :expires expires
 499                 :storage-class storage-class
 500                 :tagging tagging)))
 501
 502 (defun put-stream (stream bucket key &key
 503                    (start 0) end
 504                    access-policy
 505                    public
 506                    metadata
 507                    cache-control
 508                    content-disposition
 509                    content-encoding
 510                    (content-type "binary/octet-stream")
 511                    expires
 512                    storage-class
 513                    tagging
 514                    ((:credentials *credentials*) *credentials*)
 515                    ((:backoff *backoff*) *backoff*))
 516   (let ((content (stream-subset-vector stream start end)))
 517     (put-object content bucket key
 518                 :access-policy access-policy
 519                 :public public
 520                 :metadata metadata
 521                 :cache-control cache-control
 522                 :content-disposition content-disposition
 523                 :content-encoding content-encoding
 524                 :content-type content-type
 525                 :expires expires
 526                 :storage-class storage-class
 527                 :tagging tagging)))
 528
 529
 530 ;;; Delete & copy objects
 531
 532 (defun delete-object (bucket key &key
 533                                    ((:credentials *credentials*) *credentials*)
 534                                    ((:backoff *backoff*) *backoff*))
 535   "Delete one object from BUCKET identified by KEY."
 536   (let ((security-token (security-token *credentials*)))
 537     (submit-request (make-instance 'request
 538                                    :method :delete
 539                                    :bucket bucket
 540                                    :key key
 541                                    :amz-headers
 542                                    (when security-token
 543                                      (list (cons "security-token" security-token)))))))
 544
 545 (defun bulk-delete-document (keys)
 546   (coerce
 547    (cxml:with-xml-output (cxml:make-octet-vector-sink)
 548      (cxml:with-element "Delete"
 549        (map nil
 550             (lambda (key)
 551               (cxml:with-element "Object"
 552                 (cxml:with-element "Key"
 553                   (cxml:text (name key)))))
 554             keys)))
 555    'octet-vector))
 556
 557 (defbinder delete-objects-result
 558   ("DeleteResult"
 559    (sequence :results
 560              (alternate
 561               ("Deleted"
 562                ("Key" (bind :deleted-key)))
 563               ("Error"
 564                ("Key" (bind :error-key))
 565                ("Code" (bind :error-code))
 566                ("Message" (bind :error-message)))))))
 567
 568 (defun delete-objects (bucket keys
 569                        &key
 570                          ((:credentials *credentials*) *credentials*)
 571                          ((:backoff *backoff*) *backoff*))
 572   "Delete the objects in BUCKET identified by the sequence KEYS."
 573   (let ((deleted 0)
 574         (failed '())
 575         (subseqs (floor (length keys) 1000)))
 576     (flet ((bulk-delete (keys)
 577              (unless (<= 1 (length keys) 1000)
 578                (error "Can only delete 1 to 1000 objects per request ~
 579                        (~D attempted)."
 580                       (length keys)))
 581              (let* ((content (bulk-delete-document keys))
 582                     (md5 (vector-md5/b64 content)))
 583                (let* ((response
 584                        (submit-request (make-instance 'request
 585                                                       :method :post
 586                                                       :sub-resource "delete"
 587                                                       :bucket bucket
 588                                                       :content content
 589                                                       :content-md5 md5)))
 590                       (bindings (xml-bind 'delete-objects-result
 591                                           (body response)))
 592                       (results (bvalue :results bindings)))
 593                  (dolist (result results (values deleted failed))
 594                    (if (bvalue :deleted-key result)
 595                        (incf deleted)
 596                        (push result failed)))))))
 597       (loop for start from 0 by 1000
 598             for end = (+ start 1000)
 599             repeat subseqs do
 600             (bulk-delete (subseq keys start end)))
 601       (let ((remainder (subseq keys (* subseqs 1000))))
 602         (when (plusp (length remainder))
 603           (bulk-delete (subseq keys (* subseqs 1000)))))
 604       (values deleted failed))))
 605
 606 (defun delete-all-objects (bucket &key
 607                                     ((:credentials *credentials*) *credentials*)
 608                                     ((:backoff *backoff*) *backoff*))
 609   "Delete all objects in BUCKET."
 610   ;; FIXME: This should probably bucket-query and incrementally delete
 611   ;; instead of fetching all keys upfront.
 612   (delete-objects bucket (all-keys bucket)))
 613
 614 (defun copy-object (&key
 615                     from-bucket from-key
 616                     to-bucket to-key
 617                     when-etag-matches
 618                     unless-etag-matches
 619                     when-modified-since
 620                     unless-modified-since
 621                     (metadata nil metadata-supplied-p)
 622                     access-policy
 623                     public
 624                     precondition-errors
 625                     (storage-class "STANDARD")
 626                     (tagging nil tagging-supplied-p)
 627                       ((:credentials *credentials*) *credentials*)
 628                       ((:backoff *backoff*) *backoff*))
 629   "Copy the object identified by FROM-BUCKET/FROM-KEY to
 630 TO-BUCKET/TO-KEY.
 631
 632 If TO-BUCKET is NIL, uses FROM-BUCKET as the target. If TO-KEY is NIL,
 633 uses TO-KEY as the target.
 634
 635 If METADATA is provided, it should be an alist of metadata keys and
 636 values to set on the new object. Otherwise, the source object's
 637 metadata is copied.
 638
 639 If TAGGING is provided, it should be an alist of tag keys and values
 640 to be set on the new object's tagging resource. Otherwise, the source
 641 object's tagging is copied.
 642
 643 Optional precondition variables are WHEN-ETAG-MATCHES,
 644 UNLESS-ETAG-MATCHES, WHEN-MODIFIED-SINCE, UNLESS-MODIFIED-SINCE. The
 645 etag variables use an etag as produced by the FILE-ETAG function,
 646 i.e. a lowercase hex representation of the file's MD5 digest,
 647 surrounded by quotes. The modified-since variables should use a
 648 universal time.
 649
 650 If PUBLIC is T, the new object is visible to all
 651 users. Otherwise, a default ACL is present on the new object.
 652 "
 653   (unless from-bucket
 654     (error "FROM-BUCKET is required"))
 655   (unless from-key
 656     (error "FROM-KEY is required"))
 657   (setf to-bucket (or to-bucket from-bucket))
 658   (setf to-key (or to-key from-key))
 659   (handler-bind ((precondition-failed
 660                   (lambda (condition)
 661                     (unless precondition-errors
 662                       (return-from copy-object
 663                         (values nil (request-error-response condition)))))))
 664     (let ((headers
 665            (parameters-alist :copy-source (format nil "~A/~A"
 666                                                   (url-encode (name from-bucket))
 667                                                   (url-encode (name from-key)))
 668                              :storage-class storage-class
 669                              :metadata-directive
 670                              (if metadata-supplied-p "REPLACE" "COPY")
 671                              :tagging-directive
 672                              (if tagging-supplied-p "REPLACE" "COPY")
 673                              :copy-source-if-match when-etag-matches
 674                              :copy-source-if-none-match unless-etag-matches
 675                              :copy-source-if-modified-since
 676                              (and when-modified-since
 677                                   (http-date-string when-modified-since))
 678                              :copy-source-if-unmodified-since
 679                              (and unless-modified-since
 680                                   (http-date-string unless-modified-since))))
 681           (policy-header (access-policy-header access-policy public))
 682           (tagging-header (when tagging-supplied-p
 683                             (list (cons "tagging" (format-tagging-header tagging))))))
 684       (submit-request (make-instance 'request
 685                                      :method :put
 686                                      :bucket to-bucket
 687                                      :key to-key
 688                                      :metadata metadata
 689                                      :amz-headers
 690                                      (nconc headers
 691                                             policy-header
 692                                             tagging-header))))))
 693
 694
 695 (defun object-metadata (bucket key
 696                         &key
 697                           ((:credentials *credentials*) *credentials*)
 698                           ((:backoff *backoff*) *backoff*))
 699   "Return the metadata headers as an alist, with keywords for the keys."
 700   (let* ((prefix "X-AMZ-META-")
 701          (plen (length prefix)))
 702     (flet ((metadata-symbol-p (k)
 703              (and (< plen (length (symbol-name k)))
 704                   (string-equal k prefix :end1 plen)
 705                   (intern (subseq (symbol-name k) plen)
 706                           :keyword))))
 707       (let ((headers (head :bucket bucket :key key)))
 708         (loop for ((k . value)) on headers
 709               for meta = (metadata-symbol-p k)
 710               when meta
 711               collect (cons meta value))))))
 712
 713
 714 ;;; Convenience bit for storage class
 715
 716 (defun set-storage-class (bucket key storage-class
 717                           &key
 718                             ((:credentials *credentials*) *credentials*)
 719                             ((:backoff *backoff*) *backoff*))
 720   "Set the storage class of the object identified by BUCKET and KEY to
 721 STORAGE-CLASS."
 722   (copy-object :from-bucket bucket :from-key key
 723                :storage-class storage-class))
 724
 725
 726 ;;; ACL twiddling
 727
 728 (defparameter *public-read-grant*
 729   (make-instance 'grant
 730                  :permission :read
 731                  :grantee *all-users*)
 732   "This grant is added to or removed from an ACL to grant or revoke
 733   read access for all users.")
 734
 735 (defun get-acl (&key bucket key
 736                   ((:credentials *credentials*) *credentials*)
 737                   ((:backoff *backoff*) *backoff*))
 738   (let* ((request (make-instance 'request
 739                                  :method :get
 740                                  :bucket bucket
 741                                  :key key
 742                                  :sub-resource "acl"))
 743          (response (submit-request request))
 744          (acl (acl response)))
 745     (values (owner acl)
 746             (grants acl))))
 747
 748 (defun put-acl (owner grants &key bucket key
 749                                ((:credentials *credentials*) *credentials*)
 750                                ((:backoff *backoff*) *backoff*))
 751   (let* ((acl (make-instance 'access-control-list
 752                              :owner owner
 753                              :grants grants))
 754          (request (make-instance 'request
 755                                  :method :put
 756                                  :bucket bucket
 757                                  :key key
 758                                  :sub-resource "acl"
 759                                  :content (acl-serialize acl))))
 760   (submit-request request)))
 761
 762
 763 (defun make-public (&key bucket key
 764                       ((:credentials *credentials*) *credentials*)
 765                       ((:backoff *backoff*) *backoff*))
 766   (multiple-value-bind (owner grants)
 767       (get-acl :bucket bucket :key key)
 768     (put-acl owner
 769              (cons *public-read-grant* grants)
 770              :bucket bucket
 771              :key key)))
 772
 773 (defun make-private (&key bucket key
 774                        ((:credentials *credentials*) *credentials*)
 775                        ((:backoff *backoff*) *backoff*))
 776   (multiple-value-bind (owner grants)
 777       (get-acl :bucket bucket :key key)
 778     (setf grants
 779           (remove *all-users* grants
 780                   :test #'acl-eqv :key #'grantee))
 781     (put-acl owner grants :bucket bucket :key key)))
 782
 783
 784 ;;; Logging
 785
 786 (defparameter *log-delivery-grants*
 787   (list (make-instance 'grant
 788                        :permission :write
 789                        :grantee *log-delivery*)
 790         (make-instance 'grant
 791                        :permission :read-acl
 792                        :grantee *log-delivery*))
 793   "This list of grants is used to allow the Amazon log delivery group
 794 to write logfile objects into a particular bucket.")
 795
 796 (defun enable-logging-to (bucket &key
 797                                    ((:credentials *credentials*) *credentials*)
 798                                    ((:backoff *backoff*) *backoff*))
 799   "Configure the ACL of BUCKET to accept logfile objects."
 800   (multiple-value-bind (owner grants)
 801       (get-acl :bucket bucket)
 802     (setf grants (append *log-delivery-grants* grants))
 803     (put-acl owner grants :bucket bucket)))
 804
 805 (defun disable-logging-to (bucket &key
 806                                     ((:credentials *credentials*) *credentials*)
 807                                     ((:backoff *backoff*) *backoff*))
 808   "Configure the ACL of BUCKET to remove permissions for the log
 809 delivery group."
 810   (multiple-value-bind (owner grants)
 811       (get-acl :bucket bucket)
 812     (setf grants (remove-if (lambda (grant)
 813                               (acl-eqv (grantee grant) *log-delivery*))
 814                             grants))
 815     (put-acl owner grants :bucket bucket)))
 816
 817 (defun enable-logging (bucket target-bucket target-prefix
 818                        &key
 819                        target-grants
 820                          ((:credentials *credentials*) *credentials*)
 821                          ((:backoff *backoff*) *backoff*))
 822   "Enable logging of requests to BUCKET, putting logfile objects into
 823 TARGET-BUCKET with a key prefix of TARGET-PREFIX."
 824   (let* ((setup (make-instance 'logging-setup
 825                                :target-bucket target-bucket
 826                                :target-prefix target-prefix
 827                                :target-grants target-grants))
 828          (request (make-instance 'request
 829                                  :method :put
 830                                  :sub-resource "logging"
 831                                  :bucket bucket
 832                                  :content (log-serialize setup)))
 833          (retried nil))
 834     (loop
 835      (handler-case
 836          (return (submit-request request))
 837        (invalid-logging-target (condition)
 838          (when (starts-with "You must give the log-delivery group"
 839                             (message (request-error-response condition)))
 840            (unless retried
 841              (setf retried t)
 842              (enable-logging-to target-bucket))))))))
 843
 844
 845 (defparameter *empty-logging-setup*
 846   (log-serialize (make-instance 'logging-setup))
 847   "An empty logging setup; putting this into the logging setup of a
 848   bucket effectively disables logging.")
 849
 850 (defun disable-logging (bucket &key
 851                                  ((:credentials *credentials*) *credentials*)
 852                                  ((:backoff *backoff*) *backoff*))
 853   "Disable the creation of access logs for BUCKET."
 854   (submit-request (make-instance 'request
 855                                  :method :put
 856                                  :sub-resource "logging"
 857                                  :bucket bucket
 858                                  :content *empty-logging-setup*)))
 859
 860 (defun logging-setup (bucket &key
 861                                ((:credentials *credentials*) *credentials*)
 862                                ((:backoff *backoff*) *backoff*))
 863   (let ((setup (setup
 864                 (submit-request (make-instance 'request
 865                                                :bucket bucket
 866                                                :sub-resource "logging")))))
 867     (values (target-bucket setup)
 868             (target-prefix setup)
 869             (target-grants setup))))
 870
 871
 872
 873 ;;; Creating unauthorized and authorized URLs for a resource
 874
 875 (defclass url-based-request (request)
 876   ((expires
 877     :initarg :expires
 878     :accessor expires))
 879   (:default-initargs
 880    :expires 0))
 881
 882 (defmethod date-string ((request url-based-request))
 883   (format nil "~D" (expires request)))
 884
 885 (defun resource-url (&key bucket key vhost ssl sub-resource)
 886   (ecase vhost
 887     (:cname
 888      (format nil "http~@[s~*~]://~A/~@[~A~]~@[?~A~]"
 889              ssl bucket (url-encode key) sub-resource))
 890     (:amazon
 891      (format nil "http~@[s~*~]://~A.s3.amazonaws.com/~@[~A~]~@[?~A~]"
 892              ssl bucket (url-encode key) sub-resource))
 893     ((nil)
 894      (format nil "http~@[s~*~]://s3.amazonaws.com/~@[~A/~]~@[~A~]~@[?~A~]"
 895              ssl
 896              (url-encode bucket)
 897              (url-encode key :encode-slash nil)
 898              sub-resource))))
 899
 900 (defun authorized-url (&key bucket key vhost expires ssl sub-resource
 901                          ((:credentials *credentials*) *credentials*))
 902   (unless (and expires (integerp expires) (plusp expires))
 903     (error "~S option must be a positive integer" :expires))
 904   (let* ((region (bucket-region bucket))
 905          (region-endpoint (region-endpoint region))
 906          (endpoint (case vhost
 907                      (:cname bucket)
 908                      (:amazon (format nil "~A.~A" bucket region-endpoint))
 909                      ((nil) region-endpoint)))
 910          (request (make-instance 'url-based-request
 911                                  :method :get
 912                                  :bucket bucket
 913                                  :region region
 914                                  :endpoint endpoint
 915                                  :sub-resource sub-resource
 916                                  :key key
 917                                  :expires (unix-time expires))))
 918     (setf (amz-headers request) nil)
 919     (setf (parameters request)
 920           (parameters-alist "X-Amz-Algorithm" "AWS4-HMAC-SHA256"
 921                             "X-Amz-Credential"
 922                             (format nil "~A/~A/~A/s3/aws4_request"
 923                                     (access-key *credentials*)
 924                                     (iso8601-basic-date-string (date request))
 925                                     (region request))
 926                             "X-Amz-Date" (iso8601-basic-timestamp-string (date request))
 927                             "X-Amz-Expires" (- expires (get-universal-time))
 928                             "X-Amz-SignedHeaders"
 929                             (format nil "~{~A~^;~}" (signed-headers request))))
 930     (push (cons "X-Amz-Signature" (request-signature request))
 931           (parameters request))
 932     (let ((parameters (alist-to-url-encoded-string (parameters request))))
 933       (case vhost
 934         (:cname
 935          (format nil "http~@[s~*~]://~A/~@[~A~]?~@[~A&~]~A"
 936                  ssl
 937                  bucket
 938                  (url-encode key :encode-slash nil)
 939                  sub-resource
 940                  parameters))
 941         (:amazon
 942          (format nil "http~@[s~*~]://~A/~@[~A~]?~@[~A&~]~A"
 943                  ssl
 944                  endpoint
 945                  (url-encode key :encode-slash nil)
 946                  sub-resource
 947                  parameters))
 948         ((nil)
 949          (format nil "http~@[s~*~]://~A/~@[~A/~]~@[~A~]?~@[~A&~]~A"
 950                  ssl
 951                  endpoint
 952                  (url-encode bucket)
 953                  (url-encode key :encode-slash nil)
 954                  sub-resource
 955                  parameters))))))
 956
 957
 958 ;;; Miscellaneous operations
 959
 960 (defparameter *me-cache*
 961   (make-hash-table :test 'equal)
 962   "A cache for the result of the ME function. Keys are Amazon access
 963   key strings.")
 964
 965 (defun me (&key
 966              ((:credentials *credentials*) *credentials*)
 967              ((:backoff *backoff*) *backoff*))
 968   "Return a PERSON object corresponding to the current credentials. Cached."
 969   (or (gethash (access-key *credentials*) *me-cache*)
 970       (setf
 971        (gethash (access-key *credentials*) *me-cache*)
 972        (let ((response (submit-request (make-instance 'request))))
 973          (owner response)))))
 974
 975 (defun make-post-policy (&key expires conditions
 976                            ((:credentials *credentials*) *credentials*))
 977   "Return an encoded HTTP POST policy string and policy signature as
 978 multiple values."
 979   (unless expires
 980     (error "~S is required" :expires))
 981   (let ((policy (make-instance 'post-policy
 982                                :expires expires
 983                                :conditions conditions)))
 984     (values (policy-string64 policy)
 985             (policy-signature (secret-key *credentials*) policy))))
 986
 987 ;;; Tagging
 988
 989 (defbinder get-tagging-result
 990   ("Tagging"
 991    ("TagSet"
 992     (sequence :tag-set
 993               ("Tag"
 994                ("Key" (bind :key))
 995                ("Value" (bind :value)))))))
 996
 997 (defun get-tagging (&key bucket key
 998                       ((:credentials *credentials*) *credentials*)
 999                       ((:backoff *backoff*) *backoff*))
1000   "Returns the current contents of the object's tagging resource as an alist."
1001   (let* ((request (make-instance 'request
1002                                  :method :get
1003                                  :bucket bucket
1004                                  :key key
1005                                  :sub-resource "tagging"))
1006          (response (submit-request request))
1007          (tagging (xml-bind 'get-tagging-result (body response))))
1008     (mapcar #'(lambda (tag)
1009                 (cons (bvalue :key tag)
1010                       (bvalue :value tag)))
1011             (bvalue :tag-set tagging))))
1012
1013 (defun put-tagging (tag-set &key bucket key
1014                               ((:credentials *credentials*) *credentials*)
1015                               ((:backoff *backoff*) *backoff*))
1016   "Sets the tag set, given as an alist, to the object's tagging resource."
1017   (let* ((content (with-xml-output
1018                     (with-element "Tagging"
1019                       (with-element "TagSet"
1020                         (dolist (tag tag-set)
1021                           (with-element "Tag"
1022                             (with-element "Key" (cxml:text (car tag)))
1023                             (with-element "Value" (cxml:text (cdr tag)))))))))
1024          (request (make-instance 'request
1025                                  :method :put
1026                                  :bucket bucket
1027                                  :key key
1028                                  :sub-resource "tagging"
1029                                  :content content)))
1030     (submit-request request)))
1031
1032 (defun delete-tagging (&key bucket key
1033                          ((:credentials *credentials*) *credentials*)
1034                          ((:backoff *backoff*) *backoff*))
1035   "Deletes the object's tagging resource."
1036   (let* ((request (make-instance 'request
1037                                  :method :delete
1038                                  :bucket bucket
1039                                  :key key
1040                                  :sub-resource "tagging")))
1041     (submit-request request)))