interface.lisp

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