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