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