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