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                    ((:credentials *credentials*) *credentials*))
 326   (let ((content
 327          (etypecase object
 328            (string
 329             (flexi-streams:string-to-octets object
 330                                             :external-format
 331                                             string-external-format))
 332            ((or vector pathname) object)))
 333         (content-length t)
 334         (policy-header (access-policy-header access-policy public)))
 335     (submit-request (make-instance 'request
 336                                    :method :put
 337                                    :bucket bucket
 338                                    :key key
 339                                    :metadata metadata
 340                                    :amz-headers policy-header
 341                                    :extra-http-headers
 342                                    (parameters-alist
 343                                     :cache-control cache-control
 344                                     :content-encoding content-encoding
 345                                     :content-disposition content-disposition
 346                                     :expires (and expires
 347                                                   (http-date-string expires)))
 348                                    :content-type content-type
 349                                    :content-length content-length
 350                                    :content content))))
 351
 352
 353 (defun put-vector (vector bucket key &key
 354                    start end
 355                    access-policy
 356                    public
 357                    metadata
 358                    cache-control
 359                    content-encoding
 360                    content-disposition
 361                    (content-type "binary/octet-stream")
 362                    expires
 363                    ((:credentials *credentials*) *credentials*))
 364   (when (or start end)
 365     (setf vector (subseq vector (or start 0) end)))
 366   (put-object vector bucket key
 367               :access-policy access-policy
 368               :public public
 369               :metadata metadata
 370               :cache-control cache-control
 371               :content-encoding content-encoding
 372               :content-disposition content-disposition
 373               :content-type content-type
 374               :expires expires))
 375
 376 (defun put-string (string bucket key &key
 377                    start end
 378                    access-policy
 379                    public
 380                    metadata
 381                    (external-format :utf-8)
 382                    cache-control
 383                    content-encoding
 384                    content-disposition
 385                    (content-type "text/plain")
 386                    expires
 387                    ((:credentials *credentials*) *credentials*))
 388   (when (or start end)
 389     (setf string (subseq string (or start 0) end)))
 390   (put-object string bucket key
 391               :access-policy access-policy
 392               :public public
 393               :metadata metadata
 394               :expires expires
 395               :content-disposition content-disposition
 396               :content-encoding content-encoding
 397               :content-type content-type
 398               :cache-control cache-control
 399               :string-external-format external-format))
 400
 401
 402 (defun put-file (file bucket key &key
 403                  start end
 404                  access-policy
 405                  public
 406                  metadata
 407                  cache-control
 408                  content-disposition
 409                  content-encoding
 410                  (content-type "binary/octet-stream")
 411                  expires
 412                  ((:credentials *credentials*) *credentials*))
 413   (when (eq key t)
 414     (setf key (file-namestring file)))
 415   (let ((content (pathname file)))
 416     (when (or start end)
 417       ;;; FIXME: integrate with not-in-memory file uploading
 418       (setf content (file-subset-vector file start end)))
 419     (put-object content bucket key
 420                 :access-policy access-policy
 421                 :public public
 422                 :metadata metadata
 423                 :cache-control cache-control
 424                 :content-disposition content-disposition
 425                 :content-encoding content-encoding
 426                 :content-type content-type
 427                 :expires expires)))
 428
 429 (defun put-stream (stream bucket key &key
 430                    (start 0) end
 431                    access-policy
 432                    public
 433                    metadata
 434                    cache-control
 435                    content-disposition
 436                    content-encoding
 437                    (content-type "binary/octet-stream")
 438                    expires
 439                    ((:credentials *credentials*) *credentials*))
 440   (let ((content (stream-subset-vector stream start end)))
 441     (put-object content bucket key
 442                 :access-policy access-policy
 443                 :public public
 444                 :metadata metadata
 445                 :cache-control cache-control
 446                 :content-disposition content-disposition
 447                 :content-encoding content-encoding
 448                 :content-type content-type
 449                 :expires expires)))
 450
 451
 452 ;;; Delete & copy objects
 453
 454 (defun delete-object (bucket key &key
 455                       ((:credentials *credentials*) *credentials*))
 456   "Delete one object from BUCKET identified by KEY."
 457   (submit-request (make-instance 'request
 458                                  :method :delete
 459                                  :bucket bucket
 460                                  :key key)))
 461
 462 (defun bulk-delete-document (keys)
 463   (cxml:with-xml-output (cxml:make-octet-vector-sink)
 464     (cxml:with-element "Delete"
 465       (dolist (key keys)
 466         (cxml:with-element "Object"
 467           (cxml:with-element "Key"
 468             (cxml:text key)))))))
 469
 470 (defun delete-objects (bucket keys &key
 471                        ((:credentials *credentials*) *credentials*))
 472   "Delete the objects in BUCKET identified by KEYS."
 473   (let* ((content (bulk-delete-document keys))
 474          (md5 (vector-md5/b64 content)))
 475     (submit-request (make-instance 'request
 476                                    :method :post
 477                                    :sub-resource "delete"
 478                                    :bucket bucket
 479                                    :content content
 480                                    :content-md5 md5))))
 481
 482 (defun delete-all-objects (bucket &key
 483                            ((:credentials *credentials*) *credentials*))
 484   "Delete all objects in BUCKET."
 485   (delete-objects bucket (all-keys bucket)))
 486
 487 (defun copy-object (&key
 488                     from-bucket from-key
 489                     to-bucket to-key
 490                     when-etag-matches
 491                     unless-etag-matches
 492                     when-modified-since
 493                     unless-modified-since
 494                     (metadata nil metadata-supplied-p)
 495                     access-policy
 496                     public
 497                     precondition-errors
 498                     ((:credentials *credentials*) *credentials*))
 499   "Copy the object identified by FROM-BUCKET/FROM-KEY to
 500 TO-BUCKET/TO-KEY.
 501
 502 If TO-BUCKET is NIL, uses FROM-BUCKET as the target. If TO-KEY is NIL,
 503 uses TO-KEY as the target.
 504
 505 If METADATA is provided, it should be an alist of metadata keys and
 506 values to set on the new object. Otherwise, the source object's
 507 metadata is copied.
 508
 509 Optional precondition variables are WHEN-ETAG-MATCHES,
 510 UNLESS-ETAG-MATCHES, WHEN-MODIFIED-SINCE, UNLESS-MODIFIED-SINCE. The
 511 etag variables use an etag as produced by the FILE-ETAG function,
 512 i.e. a lowercase hex representation of the file's MD5 digest,
 513 surrounded by quotes. The modified-since variables should use a
 514 universal time.
 515
 516 If PUBLIC is T, the new object is visible to all
 517 users. Otherwise, a default ACL is present on the new object.
 518 "
 519   (unless from-bucket
 520     (error "FROM-BUCKET is required"))
 521   (unless from-key
 522     (error "FROM-KEY is required"))
 523   (unless (or to-bucket to-key)
 524     (error "Can't copy an object to itself."))
 525   (setf to-bucket (or to-bucket from-bucket))
 526   (setf to-key (or to-key from-key))
 527   (handler-bind ((precondition-failed
 528                   (lambda (condition)
 529                     (unless precondition-errors
 530                       (return-from copy-object
 531                         (values nil (request-error-response condition)))))))
 532     (let ((headers
 533            (parameters-alist :copy-source (format nil "~A/~A"
 534                                                   (url-encode (name from-bucket))
 535                                                   (url-encode (name from-key)))
 536                              :metadata-directive
 537                              (if metadata-supplied-p "REPLACE" "COPY")
 538                              :copy-source-if-match when-etag-matches
 539                              :copy-source-if-none-match unless-etag-matches
 540                              :copy-source-if-modified-since
 541                              (and when-modified-since
 542                                   (http-date-string when-modified-since))
 543                              :copy-source-if-unmodified-since
 544                              (and unless-modified-since
 545                                   (http-date-string unless-modified-since))))
 546           (policy-header (access-policy-header access-policy public)))
 547       (submit-request (make-instance 'request
 548                                      :method :put
 549                                      :bucket to-bucket
 550                                      :key to-key
 551                                      :metadata metadata
 552                                      :amz-headers
 553                                      (nconc headers policy-header))))))
 554
 555
 556 (defun object-metadata (bucket key &key
 557                         ((:credentials *credentials*) *credentials*))
 558   "Return the metadata headers as an alist, with keywords for the keys."
 559   (let* ((prefix "X-AMZ-META-")
 560          (plen (length prefix)))
 561     (flet ((metadata-symbol-p (k)
 562              (and (< plen (length (symbol-name k)))
 563                   (string-equal k prefix :end1 plen)
 564                   (intern (subseq (symbol-name k) plen)
 565                           :keyword))))
 566       (let ((headers (head :bucket bucket :key key)))
 567         (loop for ((k . value)) on headers
 568               for meta = (metadata-symbol-p k)
 569               when meta
 570               collect (cons meta value))))))
 571
 572
 573 ;;; ACL twiddling
 574
 575 (defparameter *public-read-grant*
 576   (make-instance 'grant
 577                  :permission :read
 578                  :grantee *all-users*)
 579   "This grant is added to or removed from an ACL to grant or revoke
 580   read access for all users.")
 581
 582 (defun get-acl (&key bucket key
 583                 ((:credentials *credentials*) *credentials*))
 584   (let* ((request (make-instance 'request
 585                                  :method :get
 586                                  :bucket bucket
 587                                  :key key
 588                                  :sub-resource "acl"))
 589          (response (submit-request request))
 590          (acl (acl response)))
 591     (values (owner acl)
 592             (grants acl))))
 593
 594 (defun put-acl (owner grants &key bucket key
 595                 ((:credentials *credentials*) *credentials*))
 596   (let* ((acl (make-instance 'access-control-list
 597                              :owner owner
 598                              :grants grants))
 599          (request (make-instance 'request
 600                                  :method :put
 601                                  :bucket bucket
 602                                  :key key
 603                                  :sub-resource "acl"
 604                                  :content (acl-serialize acl))))
 605   (submit-request request)))
 606
 607
 608 (defun make-public (&key bucket key
 609                     ((:credentials *credentials*) *credentials*))
 610   (multiple-value-bind (owner grants)
 611       (get-acl :bucket bucket :key key)
 612     (put-acl owner
 613              (cons *public-read-grant* grants)
 614              :bucket bucket
 615              :key key)))
 616
 617 (defun make-private (&key bucket key
 618                      ((:credentials *credentials*) *credentials*))
 619   (multiple-value-bind (owner grants)
 620       (get-acl :bucket bucket :key key)
 621     (setf grants
 622           (remove *all-users* grants
 623                   :test #'acl-eqv :key #'grantee))
 624     (put-acl owner grants :bucket bucket :key key)))
 625
 626
 627
 628 ;;; Logging
 629
 630 (defparameter *log-delivery-grants*
 631   (list (make-instance 'grant
 632                        :permission :write
 633                        :grantee *log-delivery*)
 634         (make-instance 'grant
 635                        :permission :read-acl
 636                        :grantee *log-delivery*))
 637   "This list of grants is used to allow the Amazon log delivery group
 638 to write logfile objects into a particular bucket.")
 639
 640 (defun enable-logging-to (bucket &key
 641                           ((:credentials *credentials*) *credentials*))
 642   "Configure the ACL of BUCKET to accept logfile objects."
 643   (multiple-value-bind (owner grants)
 644       (get-acl :bucket bucket)
 645     (setf grants (append *log-delivery-grants* grants))
 646     (put-acl owner grants :bucket bucket)))
 647
 648 (defun disable-logging-to (bucket &key
 649                            ((:credentials *credentials*) *credentials*))
 650   "Configure the ACL of BUCKET to remove permissions for the log
 651 delivery group."
 652   (multiple-value-bind (owner grants)
 653       (get-acl :bucket bucket)
 654     (setf grants (remove-if (lambda (grant)
 655                               (acl-eqv (grantee grant) *log-delivery*))
 656                             grants))
 657     (put-acl owner grants :bucket bucket)))
 658
 659 (defun enable-logging (bucket target-bucket target-prefix &key
 660                        target-grants
 661                        ((:credentials *credentials*) *credentials*))
 662   "Enable logging of requests to BUCKET, putting logfile objects into
 663 TARGET-BUCKET with a key prefix of TARGET-PREFIX."
 664   (let* ((setup (make-instance 'logging-setup
 665                                :target-bucket target-bucket
 666                                :target-prefix target-prefix
 667                                :target-grants target-grants))
 668          (request (make-instance 'request
 669                                  :method :put
 670                                  :sub-resource "logging"
 671                                  :bucket bucket
 672                                  :content (log-serialize setup)))
 673          (retried nil))
 674     (loop
 675      (handler-case
 676          (return (submit-request request))
 677        (invalid-logging-target (condition)
 678          (when (starts-with "You must give the log-delivery group"
 679                             (message (request-error-response condition)))
 680            (unless retried
 681              (setf retried t)
 682              (enable-logging-to target-bucket))))))))
 683
 684
 685 (defparameter *empty-logging-setup*
 686   (log-serialize (make-instance 'logging-setup))
 687   "An empty logging setup; putting this into the logging setup of a
 688   bucket effectively disables logging.")
 689
 690 (defun disable-logging (bucket &key
 691                         ((:credentials *credentials*) *credentials*))
 692   "Disable the creation of access logs for BUCKET."
 693   (submit-request (make-instance 'request
 694                                  :method :put
 695                                  :sub-resource "logging"
 696                                  :bucket bucket
 697                                  :content *empty-logging-setup*)))
 698
 699 (defun logging-setup (bucket &key
 700                       ((:credentials *credentials*) *credentials*))
 701   (let ((setup (setup
 702                 (submit-request (make-instance 'request
 703                                                :bucket bucket
 704                                                :sub-resource "logging")))))
 705     (values (target-bucket setup)
 706             (target-prefix setup)
 707             (target-grants setup))))
 708
 709
 710
 711 ;;; Creating unauthorized and authorized URLs for a resource
 712
 713 (defclass url-based-request (request)
 714   ((expires
 715     :initarg :expires
 716     :accessor expires))
 717   (:default-initargs
 718    :expires 0))
 719
 720 (defmethod date-string ((request url-based-request))
 721   (format nil "~D" (expires request)))
 722
 723 (defun resource-url (&key bucket key vhost ssl sub-resource)
 724   (ecase vhost
 725     (:cname
 726      (format nil "http~@[s~*~]://~A/~@[~A~]~@[?~A~]"
 727              ssl bucket (url-encode key) sub-resource))
 728     (:amazon
 729      (format nil "http~@[s~*~]://~A.s3.amazonaws.com/~@[~A~]~@[?~A~]"
 730              ssl bucket (url-encode key) sub-resource))
 731     ((nil)
 732      (format nil "http~@[s~*~]://s3.amazonaws.com/~@[~A/~]~@[~A~]~@[?~A~]"
 733              ssl (url-encode bucket) (url-encode key) sub-resource))))
 734
 735 (defun authorized-url (&key bucket key vhost expires ssl sub-resource
 736                        ((:credentials *credentials*) *credentials*))
 737   (unless (and expires (integerp expires) (plusp expires))
 738     (error "~S option must be a positive integer" :expires))
 739   (let* ((request (make-instance 'url-based-request
 740                                  :method :get
 741                                  :bucket bucket
 742                                  :sub-resource sub-resource
 743                                  :key key
 744                                  :expires (unix-time expires)))
 745          (parameters
 746           (alist-to-url-encoded-string
 747            (list (cons "AWSAccessKeyId" (access-key *credentials*))
 748                  (cons "Expires" (format nil "~D" (expires request)))
 749                  (cons "Signature"
 750                        (signature request))))))
 751     (case vhost
 752       (:cname
 753        (format nil "http~@[s~*~]://~A/~@[~A~]?~@[~A&~]~A"
 754                ssl bucket (url-encode key) sub-resource parameters))
 755       (:amazon
 756        (format nil "http~@[s~*~]://~A.s3.amazonaws.com/~@[~A~]?~@[~A&~]~A"
 757                ssl bucket (url-encode key) sub-resource parameters))
 758       ((nil)
 759        (format nil "http~@[s~*~]://s3.amazonaws.com/~@[~A/~]~@[~A~]?~@[~A&~]~A"
 760                ssl (url-encode bucket) (url-encode key) sub-resource
 761                    parameters)))))
 762
 763
 764 ;;; Miscellaneous operations
 765
 766 (defparameter *me-cache*
 767   (make-hash-table :test 'equal)
 768   "A cache for the result of the ME function. Keys are Amazon access
 769   key strings.")
 770
 771 (defun me (&key
 772            ((:credentials *credentials*) *credentials*))
 773   "Return a PERSON object corresponding to the current credentials. Cached."
 774   (or (gethash (access-key *credentials*) *me-cache*)
 775       (setf
 776        (gethash (access-key *credentials*) *me-cache*)
 777        (let ((response (submit-request (make-instance 'request))))
 778          (owner response)))))
 779
 780 (defun make-post-policy (&key expires conditions
 781                          ((:credentials *credentials*) *credentials*))
 782   "Return an encoded HTTP POST policy string and policy signature as
 783 multiple values."
 784   (unless expires
 785     (error "~S is required" :expires))
 786   (let ((policy (make-instance 'post-policy
 787                                :expires expires
 788                                :conditions conditions)))
 789     (values (policy-string64 policy)
 790             (policy-signature (secret-key *credentials*) policy))))