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