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       (or *s3-endpoint* "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                                            (list (cons "storage-class" storage-class))
 395                                            (when security-token
 396                                              (list (cons "security-token" security-token)))
 397                                            (when tagging
 398                                              (list
 399                                               (cons "tagging" (format-tagging-header tagging)))))
 400                                    :extra-http-headers
 401                                    (parameters-alist
 402                                     :cache-control cache-control
 403                                     :content-encoding content-encoding
 404                                     :content-disposition content-disposition
 405                                     :expires (and expires
 406                                                   (http-date-string expires)))
 407                                    :content-type content-type
 408                                    :content-length content-length
 409                                    :content content))))
 410
 411
 412 (defun put-vector (vector bucket key &key
 413                    start end
 414                    access-policy
 415                    public
 416                    metadata
 417                    cache-control
 418                    content-encoding
 419                    content-disposition
 420                    (content-type "binary/octet-stream")
 421                    expires
 422                    storage-class
 423                    tagging
 424                    ((:credentials *credentials*) *credentials*)
 425                    ((:backoff *backoff*) *backoff*))
 426   (when (or start end)
 427     (setf vector (subseq vector (or start 0) end)))
 428   (put-object vector bucket key
 429               :access-policy access-policy
 430               :public public
 431               :metadata metadata
 432               :cache-control cache-control
 433               :content-encoding content-encoding
 434               :content-disposition content-disposition
 435               :content-type content-type
 436               :expires expires
 437               :storage-class storage-class
 438               :tagging tagging))
 439
 440 (defun put-string (string bucket key &key
 441                    start end
 442                    access-policy
 443                    public
 444                    metadata
 445                    (external-format :utf-8)
 446                    cache-control
 447                    content-encoding
 448                    content-disposition
 449                    (content-type "text/plain")
 450                    expires
 451                    storage-class
 452                    tagging
 453                    ((:credentials *credentials*) *credentials*)
 454                    ((:backoff *backoff*) *backoff*))
 455   (when (or start end)
 456     (setf string (subseq string (or start 0) end)))
 457   (put-object string bucket key
 458               :access-policy access-policy
 459               :public public
 460               :metadata metadata
 461               :expires expires
 462               :content-disposition content-disposition
 463               :content-encoding content-encoding
 464               :content-type content-type
 465               :cache-control cache-control
 466               :string-external-format external-format
 467               :storage-class storage-class
 468               :tagging tagging))
 469
 470
 471 (defun put-file (file bucket key &key
 472                  start end
 473                  access-policy
 474                  public
 475                  metadata
 476                  cache-control
 477                  content-disposition
 478                  content-encoding
 479                  (content-type "binary/octet-stream")
 480                  expires
 481                  storage-class
 482                  tagging
 483                  ((:credentials *credentials*) *credentials*)
 484                  ((:backoff *backoff*) *backoff*))
 485   (when (eq key t)
 486     (setf key (file-namestring file)))
 487   (let ((content (pathname file)))
 488     (when (or start end)
 489       ;;; FIXME: integrate with not-in-memory file uploading
 490       (setf content (file-subset-vector file start end)))
 491     (put-object content bucket key
 492                 :access-policy access-policy
 493                 :public public
 494                 :metadata metadata
 495                 :cache-control cache-control
 496                 :content-disposition content-disposition
 497                 :content-encoding content-encoding
 498                 :content-type content-type
 499                 :expires expires
 500                 :storage-class storage-class
 501                 :tagging tagging)))
 502
 503 (defun put-stream (stream bucket key &key
 504                    (start 0) end
 505                    access-policy
 506                    public
 507                    metadata
 508                    cache-control
 509                    content-disposition
 510                    content-encoding
 511                    (content-type "binary/octet-stream")
 512                    expires
 513                    storage-class
 514                    tagging
 515                    ((:credentials *credentials*) *credentials*)
 516                    ((:backoff *backoff*) *backoff*))
 517   (let ((content (stream-subset-vector stream start end)))
 518     (put-object content bucket key
 519                 :access-policy access-policy
 520                 :public public
 521                 :metadata metadata
 522                 :cache-control cache-control
 523                 :content-disposition content-disposition
 524                 :content-encoding content-encoding
 525                 :content-type content-type
 526                 :expires expires
 527                 :storage-class storage-class
 528                 :tagging tagging)))
 529
 530
 531 ;;; Delete & copy objects
 532
 533 (defun delete-object (bucket key &key
 534                                    ((:credentials *credentials*) *credentials*)
 535                                    ((:backoff *backoff*) *backoff*))
 536   "Delete one object from BUCKET identified by KEY."
 537   (let ((security-token (security-token *credentials*)))
 538     (submit-request (make-instance 'request
 539                                    :method :delete
 540                                    :bucket bucket
 541                                    :key key
 542                                    :amz-headers
 543                                    (when security-token
 544                                      (list (cons "security-token" security-token)))))))
 545
 546 (defun bulk-delete-document (keys)
 547   (coerce
 548    (cxml:with-xml-output (cxml:make-octet-vector-sink)
 549      (cxml:with-element "Delete"
 550        (map nil
 551             (lambda (key)
 552               (cxml:with-element "Object"
 553                 (cxml:with-element "Key"
 554                   (cxml:text (name key)))))
 555             keys)))
 556    'octet-vector))
 557
 558 (defbinder delete-objects-result
 559   ("DeleteResult"
 560    (sequence :results
 561              (alternate
 562               ("Deleted"
 563                ("Key" (bind :deleted-key)))
 564               ("Error"
 565                ("Key" (bind :error-key))
 566                ("Code" (bind :error-code))
 567                ("Message" (bind :error-message)))))))
 568
 569 (defun delete-objects (bucket keys
 570                        &key
 571                          ((:credentials *credentials*) *credentials*)
 572                          ((:backoff *backoff*) *backoff*))
 573   "Delete the objects in BUCKET identified by the sequence KEYS."
 574   (let ((deleted 0)
 575         (failed '())
 576         (subseqs (floor (length keys) 1000)))
 577     (flet ((bulk-delete (keys)
 578              (unless (<= 1 (length keys) 1000)
 579                (error "Can only delete 1 to 1000 objects per request ~
 580                        (~D attempted)."
 581                       (length keys)))
 582              (let* ((content (bulk-delete-document keys))
 583                     (md5 (vector-md5/b64 content)))
 584                (let* ((response
 585                        (submit-request (make-instance 'request
 586                                                       :method :post
 587                                                       :sub-resource "delete"
 588                                                       :bucket bucket
 589                                                       :content content
 590                                                       :content-md5 md5)))
 591                       (bindings (xml-bind 'delete-objects-result
 592                                           (body response)))
 593                       (results (bvalue :results bindings)))
 594                  (dolist (result results (values deleted failed))
 595                    (if (bvalue :deleted-key result)
 596                        (incf deleted)
 597                        (push result failed)))))))
 598       (loop for start from 0 by 1000
 599             for end = (+ start 1000)
 600             repeat subseqs do
 601             (bulk-delete (subseq keys start end)))
 602       (let ((remainder (subseq keys (* subseqs 1000))))
 603         (when (plusp (length remainder))
 604           (bulk-delete (subseq keys (* subseqs 1000)))))
 605       (values deleted failed))))
 606
 607 (defun delete-all-objects (bucket &key
 608                                     ((:credentials *credentials*) *credentials*)
 609                                     ((:backoff *backoff*) *backoff*))
 610   "Delete all objects in BUCKET."
 611   ;; FIXME: This should probably bucket-query and incrementally delete
 612   ;; instead of fetching all keys upfront.
 613   (delete-objects bucket (all-keys bucket)))
 614
 615 (defun copy-object (&key
 616                     from-bucket from-key
 617                     to-bucket to-key
 618                     when-etag-matches
 619                     unless-etag-matches
 620                     when-modified-since
 621                     unless-modified-since
 622                     (metadata nil metadata-supplied-p)
 623                     access-policy
 624                     public
 625                     precondition-errors
 626                     (storage-class "STANDARD")
 627                     (tagging nil tagging-supplied-p)
 628                       ((:credentials *credentials*) *credentials*)
 629                       ((:backoff *backoff*) *backoff*))
 630   "Copy the object identified by FROM-BUCKET/FROM-KEY to
 631 TO-BUCKET/TO-KEY.
 632
 633 If TO-BUCKET is NIL, uses FROM-BUCKET as the target. If TO-KEY is NIL,
 634 uses TO-KEY as the target.
 635
 636 If METADATA is provided, it should be an alist of metadata keys and
 637 values to set on the new object. Otherwise, the source object's
 638 metadata is copied.
 639
 640 If TAGGING is provided, it should be an alist of tag keys and values
 641 to be set on the new object's tagging resource. Otherwise, the source
 642 object's tagging is copied.
 643
 644 Optional precondition variables are WHEN-ETAG-MATCHES,
 645 UNLESS-ETAG-MATCHES, WHEN-MODIFIED-SINCE, UNLESS-MODIFIED-SINCE. The
 646 etag variables use an etag as produced by the FILE-ETAG function,
 647 i.e. a lowercase hex representation of the file's MD5 digest,
 648 surrounded by quotes. The modified-since variables should use a
 649 universal time.
 650
 651 If PUBLIC is T, the new object is visible to all
 652 users. Otherwise, a default ACL is present on the new object.
 653 "
 654   (unless from-bucket
 655     (error "FROM-BUCKET is required"))
 656   (unless from-key
 657     (error "FROM-KEY is required"))
 658   (setf to-bucket (or to-bucket from-bucket))
 659   (setf to-key (or to-key from-key))
 660   (handler-bind ((precondition-failed
 661                   (lambda (condition)
 662                     (unless precondition-errors
 663                       (return-from copy-object
 664                         (values nil (request-error-response condition)))))))
 665     (let ((headers
 666            (parameters-alist :copy-source (format nil "~A/~A"
 667                                                   (url-encode (name from-bucket))
 668                                                   (url-encode (name from-key)))
 669                              :storage-class storage-class
 670                              :metadata-directive
 671                              (if metadata-supplied-p "REPLACE" "COPY")
 672                              :tagging-directive
 673                              (if tagging-supplied-p "REPLACE" "COPY")
 674                              :copy-source-if-match when-etag-matches
 675                              :copy-source-if-none-match unless-etag-matches
 676                              :copy-source-if-modified-since
 677                              (and when-modified-since
 678                                   (http-date-string when-modified-since))
 679                              :copy-source-if-unmodified-since
 680                              (and unless-modified-since
 681                                   (http-date-string unless-modified-since))))
 682           (policy-header (access-policy-header access-policy public))
 683           (tagging-header (when tagging-supplied-p
 684                             (list (cons "tagging" (format-tagging-header tagging))))))
 685       (submit-request (make-instance 'request
 686                                      :method :put
 687                                      :bucket to-bucket
 688                                      :key to-key
 689                                      :metadata metadata
 690                                      :amz-headers
 691                                      (nconc headers
 692                                             policy-header
 693                                             tagging-header))))))
 694
 695
 696 (defun object-metadata (bucket key
 697                         &key
 698                           ((:credentials *credentials*) *credentials*)
 699                           ((:backoff *backoff*) *backoff*))
 700   "Return the metadata headers as an alist, with keywords for the keys."
 701   (let* ((prefix "X-AMZ-META-")
 702          (plen (length prefix)))
 703     (flet ((metadata-symbol-p (k)
 704              (and (< plen (length (symbol-name k)))
 705                   (string-equal k prefix :end1 plen)
 706                   (intern (subseq (symbol-name k) plen)
 707                           :keyword))))
 708       (let ((headers (head :bucket bucket :key key)))
 709         (loop for ((k . value)) on headers
 710               for meta = (metadata-symbol-p k)
 711               when meta
 712               collect (cons meta value))))))
 713
 714
 715 ;;; Convenience bit for storage class
 716
 717 (defun set-storage-class (bucket key storage-class
 718                           &key
 719                             ((:credentials *credentials*) *credentials*)
 720                             ((:backoff *backoff*) *backoff*))
 721   "Set the storage class of the object identified by BUCKET and KEY to
 722 STORAGE-CLASS."
 723   (copy-object :from-bucket bucket :from-key key
 724                :storage-class storage-class))
 725
 726
 727 ;;; ACL twiddling
 728
 729 (defparameter *public-read-grant*
 730   (make-instance 'grant
 731                  :permission :read
 732                  :grantee *all-users*)
 733   "This grant is added to or removed from an ACL to grant or revoke
 734   read access for all users.")
 735
 736 (defun get-acl (&key bucket key
 737                   ((:credentials *credentials*) *credentials*)
 738                   ((:backoff *backoff*) *backoff*))
 739   (let* ((request (make-instance 'request
 740                                  :method :get
 741                                  :bucket bucket
 742                                  :key key
 743                                  :sub-resource "acl"))
 744          (response (submit-request request))
 745          (acl (acl response)))
 746     (values (owner acl)
 747             (grants acl))))
 748
 749 (defun put-acl (owner grants &key bucket key
 750                                ((:credentials *credentials*) *credentials*)
 751                                ((:backoff *backoff*) *backoff*))
 752   (let* ((acl (make-instance 'access-control-list
 753                              :owner owner
 754                              :grants grants))
 755          (request (make-instance 'request
 756                                  :method :put
 757                                  :bucket bucket
 758                                  :key key
 759                                  :sub-resource "acl"
 760                                  :content (acl-serialize acl))))
 761   (submit-request request)))
 762
 763
 764 (defun make-public (&key bucket key
 765                       ((:credentials *credentials*) *credentials*)
 766                       ((:backoff *backoff*) *backoff*))
 767   (multiple-value-bind (owner grants)
 768       (get-acl :bucket bucket :key key)
 769     (put-acl owner
 770              (cons *public-read-grant* grants)
 771              :bucket bucket
 772              :key key)))
 773
 774 (defun make-private (&key bucket key
 775                        ((:credentials *credentials*) *credentials*)
 776                        ((:backoff *backoff*) *backoff*))
 777   (multiple-value-bind (owner grants)
 778       (get-acl :bucket bucket :key key)
 779     (setf grants
 780           (remove *all-users* grants
 781                   :test #'acl-eqv :key #'grantee))
 782     (put-acl owner grants :bucket bucket :key key)))
 783
 784
 785 ;;; Logging
 786
 787 (defparameter *log-delivery-grants*
 788   (list (make-instance 'grant
 789                        :permission :write
 790                        :grantee *log-delivery*)
 791         (make-instance 'grant
 792                        :permission :read-acl
 793                        :grantee *log-delivery*))
 794   "This list of grants is used to allow the Amazon log delivery group
 795 to write logfile objects into a particular bucket.")
 796
 797 (defun enable-logging-to (bucket &key
 798                                    ((:credentials *credentials*) *credentials*)
 799                                    ((:backoff *backoff*) *backoff*))
 800   "Configure the ACL of BUCKET to accept logfile objects."
 801   (multiple-value-bind (owner grants)
 802       (get-acl :bucket bucket)
 803     (setf grants (append *log-delivery-grants* grants))
 804     (put-acl owner grants :bucket bucket)))
 805
 806 (defun disable-logging-to (bucket &key
 807                                     ((:credentials *credentials*) *credentials*)
 808                                     ((:backoff *backoff*) *backoff*))
 809   "Configure the ACL of BUCKET to remove permissions for the log
 810 delivery group."
 811   (multiple-value-bind (owner grants)
 812       (get-acl :bucket bucket)
 813     (setf grants (remove-if (lambda (grant)
 814                               (acl-eqv (grantee grant) *log-delivery*))
 815                             grants))
 816     (put-acl owner grants :bucket bucket)))
 817
 818 (defun enable-logging (bucket target-bucket target-prefix
 819                        &key
 820                        target-grants
 821                          ((:credentials *credentials*) *credentials*)
 822                          ((:backoff *backoff*) *backoff*))
 823   "Enable logging of requests to BUCKET, putting logfile objects into
 824 TARGET-BUCKET with a key prefix of TARGET-PREFIX."
 825   (let* ((setup (make-instance 'logging-setup
 826                                :target-bucket target-bucket
 827                                :target-prefix target-prefix
 828                                :target-grants target-grants))
 829          (request (make-instance 'request
 830                                  :method :put
 831                                  :sub-resource "logging"
 832                                  :bucket bucket
 833                                  :content (log-serialize setup)))
 834          (retried nil))
 835     (loop
 836      (handler-case
 837          (return (submit-request request))
 838        (invalid-logging-target (condition)
 839          (when (starts-with "You must give the log-delivery group"
 840                             (message (request-error-response condition)))
 841            (unless retried
 842              (setf retried t)
 843              (enable-logging-to target-bucket))))))))
 844
 845
 846 (defparameter *empty-logging-setup*
 847   (log-serialize (make-instance 'logging-setup))
 848   "An empty logging setup; putting this into the logging setup of a
 849   bucket effectively disables logging.")
 850
 851 (defun disable-logging (bucket &key
 852                                  ((:credentials *credentials*) *credentials*)
 853                                  ((:backoff *backoff*) *backoff*))
 854   "Disable the creation of access logs for BUCKET."
 855   (submit-request (make-instance 'request
 856                                  :method :put
 857                                  :sub-resource "logging"
 858                                  :bucket bucket
 859                                  :content *empty-logging-setup*)))
 860
 861 (defun logging-setup (bucket &key
 862                                ((:credentials *credentials*) *credentials*)
 863                                ((:backoff *backoff*) *backoff*))
 864   (let ((setup (setup
 865                 (submit-request (make-instance 'request
 866                                                :bucket bucket
 867                                                :sub-resource "logging")))))
 868     (values (target-bucket setup)
 869             (target-prefix setup)
 870             (target-grants setup))))
 871
 872
 873
 874 ;;; Creating unauthorized and authorized URLs for a resource
 875
 876 (defclass url-based-request (request)
 877   ((expires
 878     :initarg :expires
 879     :accessor expires))
 880   (:default-initargs
 881    :expires 0))
 882
 883 (defmethod date-string ((request url-based-request))
 884   (format nil "~D" (expires request)))
 885
 886 (defun resource-url (&key bucket key vhost ssl sub-resource)
 887   (ecase vhost
 888     (:cname
 889      (format nil "http~@[s~*~]://~A/~@[~A~]~@[?~A~]"
 890              ssl bucket (url-encode key) sub-resource))
 891     (:amazon
 892      (format nil "http~@[s~*~]://~A.s3.amazonaws.com/~@[~A~]~@[?~A~]"
 893              ssl bucket (url-encode key) sub-resource))
 894     ((nil)
 895      (format nil "http~@[s~*~]://s3.amazonaws.com/~@[~A/~]~@[~A~]~@[?~A~]"
 896              ssl
 897              (url-encode bucket)
 898              (url-encode key :encode-slash nil)
 899              sub-resource))))
 900
 901 (defun authorized-url (&key bucket key vhost expires ssl sub-resource content-disposition content-type
 902                          ((:credentials *credentials*) *credentials*))
 903   (unless (and expires (integerp expires) (plusp expires))
 904     (error "~S option must be a positive integer" :expires))
 905   (let* ((region (bucket-region bucket))
 906          (region-endpoint (region-endpoint region))
 907          (endpoint (case vhost
 908                      (:cname bucket)
 909                      (:amazon (format nil "~A.~A" bucket region-endpoint))
 910                      (:wasabi (format nil "~a.s3.wasabisys.com" bucket))
 911                      ((nil) region-endpoint)))
 912          (extra-parameters (append (if content-disposition
 913                                        (list (cons "response-content-disposition" content-disposition)))
 914                                    (if content-type
 915                                        (list (cons "response-content-type" content-type)))))
 916          (request (make-instance 'url-based-request
 917                                  :method :get
 918                                  :bucket bucket
 919                                  :region region
 920                                  :endpoint endpoint
 921                                  :sub-resource sub-resource
 922                                  :key key
 923                                  :expires (unix-time expires)
 924                                  :parameters extra-parameters)))
 925     (setf (amz-headers request) nil)
 926     (setf (parameters request)
 927           (parameters-alist "X-Amz-Algorithm" "AWS4-HMAC-SHA256"
 928                             "X-Amz-Credential"
 929                             (format nil "~A/~A/~A/s3/aws4_request"
 930                                     (access-key *credentials*)
 931                                     (iso8601-basic-date-string (date request))
 932                                     (region request))
 933                             "X-Amz-Date" (iso8601-basic-timestamp-string (date request))
 934                             "X-Amz-Expires" (- expires (get-universal-time))
 935                             "X-Amz-SignedHeaders"
 936                             (format nil "~{~A~^;~}" (signed-headers request))))
 937     (push (cons "X-Amz-Signature" (request-signature request))
 938           (parameters request))
 939     (let ((parameters (alist-to-url-encoded-string (parameters request))))
 940       (case vhost
 941         (:cname
 942          (format nil "http~@[s~*~]://~A/~@[~A~]?~@[~A&~]~A"
 943                  ssl
 944                  bucket
 945                  (url-encode key :encode-slash nil)
 946                  sub-resource
 947                  parameters))
 948         (:amazon
 949          (format nil "http~@[s~*~]://~A/~@[~A~]?~@[~A&~]~A"
 950                  ssl
 951                  endpoint
 952                  (url-encode key :encode-slash nil)
 953                  sub-resource
 954                  parameters))
 955         (:wasabi
 956          (format nil "http~@[s~*~]://~A/~@[~A~]?~@[~A&~]~A"
 957                  ssl
 958                  endpoint
 959                  (url-encode key :encode-slash nil)
 960                  sub-resource
 961                  parameters))
 962         ((nil)
 963          (format nil "http~@[s~*~]://~A/~@[~A/~]~@[~A~]?~@[~A&~]~A"
 964                  ssl
 965                  endpoint
 966                  (url-encode bucket)
 967                  (url-encode key :encode-slash nil)
 968                  sub-resource
 969                  parameters))))))
 970
 971 ;;; Miscellaneous operations
 972
 973 (defparameter *me-cache*
 974   (make-hash-table :test 'equal)
 975   "A cache for the result of the ME function. Keys are Amazon access
 976   key strings.")
 977
 978 (defun me (&key
 979              ((:credentials *credentials*) *credentials*)
 980              ((:backoff *backoff*) *backoff*))
 981   "Return a PERSON object corresponding to the current credentials. Cached."
 982   (or (gethash (access-key *credentials*) *me-cache*)
 983       (setf
 984        (gethash (access-key *credentials*) *me-cache*)
 985        (let ((response (submit-request (make-instance 'request))))
 986          (owner response)))))
 987
 988 (defun make-post-policy (&key expires conditions
 989                            ((:credentials *credentials*) *credentials*))
 990   "Return an encoded HTTP POST policy string and policy signature as
 991 multiple values."
 992   (unless expires
 993     (error "~S is required" :expires))
 994   (let ((policy (make-instance 'post-policy
 995                                :expires expires
 996                                :conditions conditions)))
 997     (values (policy-string64 policy)
 998             (policy-signature (secret-key *credentials*) policy))))
 999
1000 ;;; Tagging
1001
1002 (defbinder get-tagging-result
1003   ("Tagging"
1004    ("TagSet"
1005     (sequence :tag-set
1006               ("Tag"
1007                ("Key" (bind :key))
1008                ("Value" (bind :value)))))))
1009
1010 (defun get-tagging (&key bucket key
1011                       ((:credentials *credentials*) *credentials*)
1012                       ((:backoff *backoff*) *backoff*))
1013   "Returns the current contents of the object's tagging resource as an alist."
1014   (let* ((request (make-instance 'request
1015                                  :method :get
1016                                  :bucket bucket
1017                                  :key key
1018                                  :sub-resource "tagging"))
1019          (response (submit-request request))
1020          (tagging (xml-bind 'get-tagging-result (body response))))
1021     (mapcar #'(lambda (tag)
1022                 (cons (bvalue :key tag)
1023                       (bvalue :value tag)))
1024             (bvalue :tag-set tagging))))
1025
1026 (defun put-tagging (tag-set &key bucket key
1027                               ((:credentials *credentials*) *credentials*)
1028                               ((:backoff *backoff*) *backoff*))
1029   "Sets the tag set, given as an alist, to the object's tagging resource."
1030   (let* ((content (with-xml-output
1031                     (with-element "Tagging"
1032                       (with-element "TagSet"
1033                         (dolist (tag tag-set)
1034                           (with-element "Tag"
1035                             (with-element "Key" (cxml:text (car tag)))
1036                             (with-element "Value" (cxml:text (cdr tag)))))))))
1037          (request (make-instance 'request
1038                                  :method :put
1039                                  :bucket bucket
1040                                  :key key
1041                                  :sub-resource "tagging"
1042                                  :content content)))
1043     (submit-request request)))
1044
1045 (defun delete-tagging (&key bucket key
1046                          ((:credentials *credentials*) *credentials*)
1047                          ((:backoff *backoff*) *backoff*))
1048   "Deletes the object's tagging resource."
1049   (let* ((request (make-instance 'request
1050                                  :method :delete
1051                                  :bucket bucket
1052                                  :key key
1053                                  :sub-resource "tagging")))
1054     (submit-request request)))