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 make-string-writer-handler (external-format)
 190   (lambda (response)
 191     (setf response (vector-writer-handler response))
 192     (setf (body response)
 193           (flexi-streams:octets-to-string (body response)
 194                                     :external-format external-format))
 195     response))
 196
 197 (defun get-object (bucket key &key
 198                    when-modified-since
 199                    unless-modified-since
 200                    when-etag-matches
 201                    unless-etag-matches
 202                    start end
 203                    (output :vector)
 204                    (if-exists :supersede)
 205                    (string-external-format :utf-8)
 206                    ((:credentials *credentials*) *credentials*))
 207   (flet ((range-argument (start end)
 208            (when start
 209              (format nil "bytes=~D-~@[~D~]" start (and end (1- end)))))
 210          (maybe-date (time)
 211            (and time (http-date-string time))))
 212     (when (and end (not start))
 213       (setf start 0))
 214     (when (and start end (<= end start))
 215       (error "START must be less than END."))
 216     (let ((request (make-instance 'request
 217                                   :method :get
 218                                   :bucket bucket
 219                                   :key key
 220                                   :extra-http-headers
 221                                   (parameters-alist
 222                                    :connection "close"
 223                                    :if-modified-since
 224                                    (maybe-date when-modified-since)
 225                                    :if-unmodified-since
 226                                    (maybe-date unless-modified-since)
 227                                    :if-match when-etag-matches
 228                                    :if-none-match unless-etag-matches
 229                                    :range (range-argument start end))))
 230           (handler (cond ((eql output :vector)
 231                           'vector-writer-handler)
 232                          ((eql output :string)
 233                           (make-string-writer-handler string-external-format))
 234                          ((or (stringp output)
 235                               (pathnamep output))
 236                           (make-file-writer-handler output :if-exists if-exists))
 237                          (t
 238                           (error "Unknown ~S option ~S -- should be ~
 239                                 :VECTOR, :STRING, or a pathname"
 240                                  :output output)))))
 241       (catch 'not-modified
 242         (handler-case
 243             (let ((response (submit-request request
 244                                             :body-stream t
 245                                             :handler handler)))
 246               (values (body response) (http-headers response)))
 247           (precondition-failed (c)
 248             (throw 'not-modified
 249               (values nil
 250                       (http-headers (request-error-response c))))))))))
 251
 252 (defun get-vector (bucket key
 253                    &key start end
 254                    when-modified-since unless-modified-since
 255                    when-etag-matches unless-etag-matches
 256                    (if-exists :supersede)
 257                    ((:credentials *credentials*) *credentials*))
 258   (get-object bucket key
 259               :output :vector
 260               :start start
 261               :end end
 262               :when-modified-since when-modified-since
 263               :unless-modified-since unless-modified-since
 264               :when-etag-matches when-etag-matches
 265               :unless-etag-matches unless-etag-matches
 266               :if-exists if-exists))
 267
 268 (defun get-string (bucket key
 269                    &key start end
 270                    (external-format :utf-8)
 271                    when-modified-since unless-modified-since
 272                    when-etag-matches unless-etag-matches
 273                    (if-exists :supersede)
 274                    ((:credentials *credentials*) *credentials*))
 275   (get-object bucket key
 276               :output :string
 277               :string-external-format external-format
 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-file (bucket key file
 287                  &key start end
 288                  when-modified-since unless-modified-since
 289                  when-etag-matches unless-etag-matches
 290                  (if-exists :supersede)
 291                  ((:credentials *credentials*) *credentials*))
 292   (get-object bucket key
 293               :output (pathname file)
 294               :start start
 295               :end end
 296               :when-modified-since when-modified-since
 297               :unless-modified-since unless-modified-since
 298               :when-etag-matches when-etag-matches
 299               :unless-etag-matches unless-etag-matches
 300               :if-exists if-exists))
 301
 302
 303 ;;; Putting objects
 304
 305
 306 (defun put-object (object bucket key &key
 307                    access-policy
 308                    public
 309                    metadata
 310                    (string-external-format :utf-8)
 311                    cache-control
 312                    content-encoding
 313                    content-disposition
 314                    expires
 315                    content-type
 316                    ((:credentials *credentials*) *credentials*))
 317   (let ((content
 318          (etypecase object
 319            (string
 320             (flexi-streams:string-to-octets object
 321                                             :external-format
 322                                             string-external-format))
 323            ((or vector pathname) object)))
 324         (content-length t)
 325         (policy-header (access-policy-header access-policy public)))
 326     (submit-request (make-instance 'request
 327                                    :method :put
 328                                    :bucket bucket
 329                                    :key key
 330                                    :metadata metadata
 331                                    :amz-headers policy-header
 332                                    :extra-http-headers
 333                                    (parameters-alist
 334                                     :cache-control cache-control
 335                                     :content-encoding content-encoding
 336                                     :content-disposition content-disposition
 337                                     :expires (and expires
 338                                                   (http-date-string expires)))
 339                                    :content-type content-type
 340                                    :content-length content-length
 341                                    :content content))))
 342
 343
 344 (defun put-vector (vector bucket key &key
 345                    start end
 346                    access-policy
 347                    public
 348                    metadata
 349                    cache-control
 350                    content-encoding
 351                    content-disposition
 352                    (content-type "binary/octet-stream")
 353                    expires
 354                    ((:credentials *credentials*) *credentials*))
 355   (when (or start end)
 356     (setf vector (subseq vector (or start 0) end)))
 357   (put-object vector bucket key
 358               :access-policy access-policy
 359               :public public
 360               :metadata metadata
 361               :cache-control cache-control
 362               :content-encoding content-encoding
 363               :content-disposition content-disposition
 364               :content-type content-type
 365               :expires expires))
 366
 367 (defun put-string (string bucket key &key
 368                    start end
 369                    access-policy
 370                    public
 371                    metadata
 372                    (external-format :utf-8)
 373                    cache-control
 374                    content-encoding
 375                    content-disposition
 376                    (content-type "text/plain")
 377                    expires
 378                    ((:credentials *credentials*) *credentials*))
 379   (when (or start end)
 380     (setf string (subseq string (or start 0) end)))
 381   (put-object string bucket key
 382               :access-policy access-policy
 383               :public public
 384               :metadata metadata
 385               :expires expires
 386               :content-disposition content-disposition
 387               :content-encoding content-encoding
 388               :content-type content-type
 389               :cache-control cache-control
 390               :string-external-format external-format))
 391
 392
 393 (defun put-file (file bucket key &key
 394                  start end
 395                  access-policy
 396                  public
 397                  metadata
 398                  cache-control
 399                  content-disposition
 400                  content-encoding
 401                  (content-type "binary/octet-stream")
 402                  expires
 403                  ((:credentials *credentials*) *credentials*))
 404   (when (eq key t)
 405     (setf key (file-namestring file)))
 406   (let ((content (pathname file)))
 407     (when (or start end)
 408       ;;; FIXME: integrate with not-in-memory file uploading
 409       (setf content (file-subset-vector file start end)))
 410     (put-object content bucket key
 411                 :access-policy access-policy
 412                 :public public
 413                 :metadata metadata
 414                 :cache-control cache-control
 415                 :content-disposition content-disposition
 416                 :content-encoding content-encoding
 417                 :content-type content-type
 418                 :expires expires)))
 419
 420 (defun put-stream (stream bucket key &key
 421                    (start 0) 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                    ((:credentials *credentials*) *credentials*))
 431   (let ((content (stream-subset-vector stream start end)))
 432     (put-object content bucket key
 433                 :access-policy access-policy
 434                 :public public
 435                 :metadata metadata
 436                 :cache-control cache-control
 437                 :content-disposition content-disposition
 438                 :content-encoding content-encoding
 439                 :content-type content-type
 440                 :expires expires)))
 441
 442
 443 ;;; Delete & copy objects
 444
 445 (defun delete-object (bucket key &key
 446                       ((:credentials *credentials*) *credentials*))
 447   "Delete one object from BUCKET identified by KEY."
 448   (submit-request (make-instance 'request
 449                                  :method :delete
 450                                  :bucket bucket
 451                                  :key key)))
 452
 453 (defun delete-objects (bucket keys &key
 454                        ((:credentials *credentials*) *credentials*))
 455   "Delete the objects in BUCKET identified by KEYS."
 456   (map nil
 457        (lambda (key)
 458          (delete-object bucket key))
 459        keys)
 460   (length keys))
 461
 462 (defun delete-all-objects (bucket &key
 463                            ((:credentials *credentials*) *credentials*))
 464   "Delete all objects in BUCKET."
 465   (delete-objects bucket (all-keys bucket)))
 466
 467 (defun copy-object (&key
 468                     from-bucket from-key
 469                     to-bucket to-key
 470                     when-etag-matches
 471                     unless-etag-matches
 472                     when-modified-since
 473                     unless-modified-since
 474                     (metadata nil metadata-supplied-p)
 475                     access-policy
 476                     public
 477                     precondition-errors
 478                     ((:credentials *credentials*) *credentials*))
 479   "Copy the object identified by FROM-BUCKET/FROM-KEY to
 480 TO-BUCKET/TO-KEY.
 481
 482 If TO-BUCKET is NIL, uses FROM-BUCKET as the target. If TO-KEY is NIL,
 483 uses TO-KEY as the target.
 484
 485 If METADATA is provided, it should be an alist of metadata keys and
 486 values to set on the new object. Otherwise, the source object's
 487 metadata is copied.
 488
 489 Optional precondition variables are WHEN-ETAG-MATCHES,
 490 UNLESS-ETAG-MATCHES, WHEN-MODIFIED-SINCE, UNLESS-MODIFIED-SINCE. The
 491 etag variables use an etag as produced by the FILE-ETAG function,
 492 i.e. a lowercase hex representation of the file's MD5 digest,
 493 surrounded by quotes. The modified-since variables should use a
 494 universal time.
 495
 496 If PUBLIC is T, the new object is visible to all
 497 users. Otherwise, a default ACL is present on the new object.
 498 "
 499   (unless from-bucket
 500     (error "FROM-BUCKET is required"))
 501   (unless from-key
 502     (error "FROM-KEY is required"))
 503   (unless (or to-bucket to-key)
 504     (error "Can't copy an object to itself."))
 505   (setf to-bucket (or to-bucket from-bucket))
 506   (setf to-key (or to-key from-key))
 507   (handler-bind ((precondition-failed
 508                   (lambda (condition)
 509                     (unless precondition-errors
 510                       (return-from copy-object
 511                         (values nil (request-error-response condition)))))))
 512     (let ((headers
 513            (parameters-alist :copy-source (format nil "~A/~A"
 514                                                   (url-encode (name from-bucket))
 515                                                   (url-encode (name from-key)))
 516                              :metadata-directive
 517                              (if metadata-supplied-p "REPLACE" "COPY")
 518                              :copy-source-if-match when-etag-matches
 519                              :copy-source-if-none-match unless-etag-matches
 520                              :copy-source-if-modified-since
 521                              (and when-modified-since
 522                                   (http-date-string when-modified-since))
 523                              :copy-source-if-unmodified-since
 524                              (and unless-modified-since
 525                                   (http-date-string unless-modified-since))))
 526           (policy-header (access-policy-header access-policy public)))
 527       (submit-request (make-instance 'request
 528                                      :method :put
 529                                      :bucket to-bucket
 530                                      :key to-key
 531                                      :metadata metadata
 532                                      :amz-headers
 533                                      (nconc headers policy-header))))))
 534
 535
 536 (defun object-metadata (bucket key &key
 537                         ((:credentials *credentials*) *credentials*))
 538   "Return the metadata headers as an alist, with keywords for the keys."
 539   (let* ((prefix "X-AMZ-META-")
 540          (plen (length prefix)))
 541     (flet ((metadata-symbol-p (k)
 542              (and (< plen (length (symbol-name k)))
 543                   (string-equal k prefix :end1 plen)
 544                   (intern (subseq (symbol-name k) plen)
 545                           :keyword))))
 546       (let ((headers (head :bucket bucket :key key)))
 547         (loop for ((k . value)) on headers
 548               for meta = (metadata-symbol-p k)
 549               when meta
 550               collect (cons meta value))))))
 551
 552
 553 ;;; ACL twiddling
 554
 555 (defparameter *public-read-grant*
 556   (make-instance 'grant
 557                  :permission :read
 558                  :grantee *all-users*)
 559   "This grant is added to or removed from an ACL to grant or revoke
 560   read access for all users.")
 561
 562 (defun get-acl (&key bucket key
 563                 ((:credentials *credentials*) *credentials*))
 564   (let* ((request (make-instance 'request
 565                                  :method :get
 566                                  :bucket bucket
 567                                  :key key
 568                                  :sub-resource "acl"))
 569          (response (submit-request request))
 570          (acl (acl response)))
 571     (values (owner acl)
 572             (grants acl))))
 573
 574 (defun put-acl (owner grants &key bucket key
 575                 ((:credentials *credentials*) *credentials*))
 576   (let* ((acl (make-instance 'access-control-list
 577                              :owner owner
 578                              :grants grants))
 579          (request (make-instance 'request
 580                                  :method :put
 581                                  :bucket bucket
 582                                  :key key
 583                                  :sub-resource "acl"
 584                                  :content (acl-serialize acl))))
 585   (submit-request request)))
 586
 587
 588 (defun make-public (&key bucket key
 589                     ((:credentials *credentials*) *credentials*))
 590   (multiple-value-bind (owner grants)
 591       (get-acl :bucket bucket :key key)
 592     (put-acl owner
 593              (cons *public-read-grant* grants)
 594              :bucket bucket
 595              :key key)))
 596
 597 (defun make-private (&key bucket key
 598                      ((:credentials *credentials*) *credentials*))
 599   (multiple-value-bind (owner grants)
 600       (get-acl :bucket bucket :key key)
 601     (setf grants
 602           (remove *all-users* grants
 603                   :test #'acl-eqv :key #'grantee))
 604     (put-acl owner grants :bucket bucket :key key)))
 605
 606
 607
 608 ;;; Logging
 609
 610 (defparameter *log-delivery-grants*
 611   (list (make-instance 'grant
 612                        :permission :write
 613                        :grantee *log-delivery*)
 614         (make-instance 'grant
 615                        :permission :read-acl
 616                        :grantee *log-delivery*))
 617   "This list of grants is used to allow the Amazon log delivery group
 618 to write logfile objects into a particular bucket.")
 619
 620 (defun enable-logging-to (bucket &key
 621                           ((:credentials *credentials*) *credentials*))
 622   "Configure the ACL of BUCKET to accept logfile objects."
 623   (multiple-value-bind (owner grants)
 624       (get-acl :bucket bucket)
 625     (setf grants (append *log-delivery-grants* grants))
 626     (put-acl owner grants :bucket bucket)))
 627
 628 (defun disable-logging-to (bucket &key
 629                            ((:credentials *credentials*) *credentials*))
 630   "Configure the ACL of BUCKET to remove permissions for the log
 631 delivery group."
 632   (multiple-value-bind (owner grants)
 633       (get-acl :bucket bucket)
 634     (setf grants (remove-if (lambda (grant)
 635                               (acl-eqv (grantee grant) *log-delivery*))
 636                             grants))
 637     (put-acl owner grants :bucket bucket)))
 638
 639 (defun enable-logging (bucket target-bucket target-prefix &key
 640                        target-grants
 641                        ((:credentials *credentials*) *credentials*))
 642   "Enable logging of requests to BUCKET, putting logfile objects into
 643 TARGET-BUCKET with a key prefix of TARGET-PREFIX."
 644   (let* ((setup (make-instance 'logging-setup
 645                                :target-bucket target-bucket
 646                                :target-prefix target-prefix
 647                                :target-grants target-grants))
 648          (request (make-instance 'request
 649                                  :method :put
 650                                  :sub-resource "logging"
 651                                  :bucket bucket
 652                                  :content (log-serialize setup)))
 653          (retried nil))
 654     (loop
 655      (handler-case
 656          (return (submit-request request))
 657        (invalid-logging-target (condition)
 658          (when (starts-with "You must give the log-delivery group"
 659                             (message (request-error-response condition)))
 660            (unless retried
 661              (setf retried t)
 662              (enable-logging-to target-bucket))))))))
 663
 664
 665 (defparameter *empty-logging-setup*
 666   (log-serialize (make-instance 'logging-setup))
 667   "An empty logging setup; putting this into the logging setup of a
 668   bucket effectively disables logging.")
 669
 670 (defun disable-logging (bucket &key
 671                         ((:credentials *credentials*) *credentials*))
 672   "Disable the creation of access logs for BUCKET."
 673   (submit-request (make-instance 'request
 674                                  :method :put
 675                                  :sub-resource "logging"
 676                                  :bucket bucket
 677                                  :content *empty-logging-setup*)))
 678
 679 (defun logging-setup (bucket &key
 680                       ((:credentials *credentials*) *credentials*))
 681   (let ((setup (setup
 682                 (submit-request (make-instance 'request
 683                                                :bucket bucket
 684                                                :sub-resource "logging")))))
 685     (values (target-bucket setup)
 686             (target-prefix setup)
 687             (target-grants setup))))
 688
 689
 690
 691 ;;; Creating unauthorized and authorized URLs for a resource
 692
 693 (defclass url-based-request (request)
 694   ((expires
 695     :initarg :expires
 696     :accessor expires))
 697   (:default-initargs
 698    :expires 0))
 699
 700 (defmethod date-string ((request url-based-request))
 701   (format nil "~D" (expires request)))
 702
 703 (defun resource-url (&key bucket key vhost ssl sub-resource)
 704   (case vhost
 705     (:cname
 706      (format nil "http~@[s~*~]://~A/~@[~A~]~@[?~A~]"
 707              ssl bucket (url-encode key) sub-resource))
 708     (:amazon
 709      (format nil "http~@[s~*~]://~A.s3.amazonaws.com/~@[~A~]~@[?~A~]"
 710              ssl bucket (url-encode key) sub-resource))
 711     ((nil)
 712      (format nil "http~@[s~*~]://s3.amazonaws.com/~@[~A/~]~@[~A~]~@[?~A~]"
 713              ssl (url-encode bucket) (url-encode key) sub-resource))))
 714
 715 (defun authorized-url (&key bucket key vhost expires ssl sub-resource
 716                        ((:credentials *credentials*) *credentials*))
 717   (unless (and expires (integerp expires) (plusp expires))
 718     (error "~S option must be a positive integer" :expires))
 719   (let* ((request (make-instance 'url-based-request
 720                                  :method :get
 721                                  :bucket bucket
 722                                  :sub-resource sub-resource
 723                                  :key key
 724                                  :expires (unix-time expires)))
 725          (parameters
 726           (alist-to-url-encoded-string
 727            (list (cons "AWSAccessKeyId" (access-key *credentials*))
 728                  (cons "Expires" (format nil "~D" (expires request)))
 729                  (cons "Signature"
 730                        (signature request))))))
 731     (case vhost
 732       (:cname
 733        (format nil "http~@[s~*~]://~A/~@[~A~]?~@[~A&~]~A"
 734                ssl bucket (url-encode key) sub-resource parameters))
 735       (:amazon
 736        (format nil "http~@[s~*~]://~A.s3.amazonaws.com/~@[~A~]?~@[~A&~]~A"
 737                ssl bucket (url-encode key) sub-resource parameters))
 738       ((nil)
 739        (format nil "http~@[s~*~]://s3.amazonaws.com/~@[~A/~]~@[~A~]?~@[~A&~]~A"
 740                ssl (url-encode bucket) (url-encode key) sub-resource
 741                    parameters)))))
 742
 743
 744 ;;; Miscellaneous operations
 745
 746 (defparameter *me-cache*
 747   (make-hash-table :test 'equal)
 748   "A cache for the result of the ME function. Keys are Amazon access
 749   key strings.")
 750
 751 (defun me (&key
 752            ((:credentials *credentials*) *credentials*))
 753   "Return a PERSON object corresponding to the current credentials. Cached."
 754   (or (gethash (access-key *credentials*) *me-cache*)
 755       (setf
 756        (gethash (access-key *credentials*) *me-cache*)
 757        (let ((response (submit-request (make-instance 'request))))
 758          (owner response)))))
 759
 760 (defun make-post-policy (&key expires conditions
 761                          ((:credentials *credentials*) *credentials*))
 762   "Return an encoded HTTP POST policy string and policy signature as
 763 multiple values."
 764   (unless expires
 765     (error "~S is required" :expires))
 766   (let ((policy (make-instance 'post-policy
 767                                :expires expires
 768                                :conditions conditions)))
 769     (values (policy-string64 policy)
 770             (policy-signature (secret-key *credentials*) policy))))