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 delete-objects (bucket keys &key
 463                        ((:credentials *credentials*) *credentials*))
 464   "Delete the objects in BUCKET identified by KEYS."
 465   (map nil
 466        (lambda (key)
 467          (delete-object bucket key))
 468        keys)
 469   (length keys))
 470
 471 (defun delete-all-objects (bucket &key
 472                            ((:credentials *credentials*) *credentials*))
 473   "Delete all objects in BUCKET."
 474   (delete-objects bucket (all-keys bucket)))
 475
 476 (defun copy-object (&key
 477                     from-bucket from-key
 478                     to-bucket to-key
 479                     when-etag-matches
 480                     unless-etag-matches
 481                     when-modified-since
 482                     unless-modified-since
 483                     (metadata nil metadata-supplied-p)
 484                     access-policy
 485                     public
 486                     precondition-errors
 487                     ((:credentials *credentials*) *credentials*))
 488   "Copy the object identified by FROM-BUCKET/FROM-KEY to
 489 TO-BUCKET/TO-KEY.
 490
 491 If TO-BUCKET is NIL, uses FROM-BUCKET as the target. If TO-KEY is NIL,
 492 uses TO-KEY as the target.
 493
 494 If METADATA is provided, it should be an alist of metadata keys and
 495 values to set on the new object. Otherwise, the source object's
 496 metadata is copied.
 497
 498 Optional precondition variables are WHEN-ETAG-MATCHES,
 499 UNLESS-ETAG-MATCHES, WHEN-MODIFIED-SINCE, UNLESS-MODIFIED-SINCE. The
 500 etag variables use an etag as produced by the FILE-ETAG function,
 501 i.e. a lowercase hex representation of the file's MD5 digest,
 502 surrounded by quotes. The modified-since variables should use a
 503 universal time.
 504
 505 If PUBLIC is T, the new object is visible to all
 506 users. Otherwise, a default ACL is present on the new object.
 507 "
 508   (unless from-bucket
 509     (error "FROM-BUCKET is required"))
 510   (unless from-key
 511     (error "FROM-KEY is required"))
 512   (unless (or to-bucket to-key)
 513     (error "Can't copy an object to itself."))
 514   (setf to-bucket (or to-bucket from-bucket))
 515   (setf to-key (or to-key from-key))
 516   (handler-bind ((precondition-failed
 517                   (lambda (condition)
 518                     (unless precondition-errors
 519                       (return-from copy-object
 520                         (values nil (request-error-response condition)))))))
 521     (let ((headers
 522            (parameters-alist :copy-source (format nil "~A/~A"
 523                                                   (url-encode (name from-bucket))
 524                                                   (url-encode (name from-key)))
 525                              :metadata-directive
 526                              (if metadata-supplied-p "REPLACE" "COPY")
 527                              :copy-source-if-match when-etag-matches
 528                              :copy-source-if-none-match unless-etag-matches
 529                              :copy-source-if-modified-since
 530                              (and when-modified-since
 531                                   (http-date-string when-modified-since))
 532                              :copy-source-if-unmodified-since
 533                              (and unless-modified-since
 534                                   (http-date-string unless-modified-since))))
 535           (policy-header (access-policy-header access-policy public)))
 536       (submit-request (make-instance 'request
 537                                      :method :put
 538                                      :bucket to-bucket
 539                                      :key to-key
 540                                      :metadata metadata
 541                                      :amz-headers
 542                                      (nconc headers policy-header))))))
 543
 544
 545 (defun object-metadata (bucket key &key
 546                         ((:credentials *credentials*) *credentials*))
 547   "Return the metadata headers as an alist, with keywords for the keys."
 548   (let* ((prefix "X-AMZ-META-")
 549          (plen (length prefix)))
 550     (flet ((metadata-symbol-p (k)
 551              (and (< plen (length (symbol-name k)))
 552                   (string-equal k prefix :end1 plen)
 553                   (intern (subseq (symbol-name k) plen)
 554                           :keyword))))
 555       (let ((headers (head :bucket bucket :key key)))
 556         (loop for ((k . value)) on headers
 557               for meta = (metadata-symbol-p k)
 558               when meta
 559               collect (cons meta value))))))
 560
 561
 562 ;;; ACL twiddling
 563
 564 (defparameter *public-read-grant*
 565   (make-instance 'grant
 566                  :permission :read
 567                  :grantee *all-users*)
 568   "This grant is added to or removed from an ACL to grant or revoke
 569   read access for all users.")
 570
 571 (defun get-acl (&key bucket key
 572                 ((:credentials *credentials*) *credentials*))
 573   (let* ((request (make-instance 'request
 574                                  :method :get
 575                                  :bucket bucket
 576                                  :key key
 577                                  :sub-resource "acl"))
 578          (response (submit-request request))
 579          (acl (acl response)))
 580     (values (owner acl)
 581             (grants acl))))
 582
 583 (defun put-acl (owner grants &key bucket key
 584                 ((:credentials *credentials*) *credentials*))
 585   (let* ((acl (make-instance 'access-control-list
 586                              :owner owner
 587                              :grants grants))
 588          (request (make-instance 'request
 589                                  :method :put
 590                                  :bucket bucket
 591                                  :key key
 592                                  :sub-resource "acl"
 593                                  :content (acl-serialize acl))))
 594   (submit-request request)))
 595
 596
 597 (defun make-public (&key bucket key
 598                     ((:credentials *credentials*) *credentials*))
 599   (multiple-value-bind (owner grants)
 600       (get-acl :bucket bucket :key key)
 601     (put-acl owner
 602              (cons *public-read-grant* grants)
 603              :bucket bucket
 604              :key key)))
 605
 606 (defun make-private (&key bucket key
 607                      ((:credentials *credentials*) *credentials*))
 608   (multiple-value-bind (owner grants)
 609       (get-acl :bucket bucket :key key)
 610     (setf grants
 611           (remove *all-users* grants
 612                   :test #'acl-eqv :key #'grantee))
 613     (put-acl owner grants :bucket bucket :key key)))
 614
 615
 616
 617 ;;; Logging
 618
 619 (defparameter *log-delivery-grants*
 620   (list (make-instance 'grant
 621                        :permission :write
 622                        :grantee *log-delivery*)
 623         (make-instance 'grant
 624                        :permission :read-acl
 625                        :grantee *log-delivery*))
 626   "This list of grants is used to allow the Amazon log delivery group
 627 to write logfile objects into a particular bucket.")
 628
 629 (defun enable-logging-to (bucket &key
 630                           ((:credentials *credentials*) *credentials*))
 631   "Configure the ACL of BUCKET to accept logfile objects."
 632   (multiple-value-bind (owner grants)
 633       (get-acl :bucket bucket)
 634     (setf grants (append *log-delivery-grants* grants))
 635     (put-acl owner grants :bucket bucket)))
 636
 637 (defun disable-logging-to (bucket &key
 638                            ((:credentials *credentials*) *credentials*))
 639   "Configure the ACL of BUCKET to remove permissions for the log
 640 delivery group."
 641   (multiple-value-bind (owner grants)
 642       (get-acl :bucket bucket)
 643     (setf grants (remove-if (lambda (grant)
 644                               (acl-eqv (grantee grant) *log-delivery*))
 645                             grants))
 646     (put-acl owner grants :bucket bucket)))
 647
 648 (defun enable-logging (bucket target-bucket target-prefix &key
 649                        target-grants
 650                        ((:credentials *credentials*) *credentials*))
 651   "Enable logging of requests to BUCKET, putting logfile objects into
 652 TARGET-BUCKET with a key prefix of TARGET-PREFIX."
 653   (let* ((setup (make-instance 'logging-setup
 654                                :target-bucket target-bucket
 655                                :target-prefix target-prefix
 656                                :target-grants target-grants))
 657          (request (make-instance 'request
 658                                  :method :put
 659                                  :sub-resource "logging"
 660                                  :bucket bucket
 661                                  :content (log-serialize setup)))
 662          (retried nil))
 663     (loop
 664      (handler-case
 665          (return (submit-request request))
 666        (invalid-logging-target (condition)
 667          (when (starts-with "You must give the log-delivery group"
 668                             (message (request-error-response condition)))
 669            (unless retried
 670              (setf retried t)
 671              (enable-logging-to target-bucket))))))))
 672
 673
 674 (defparameter *empty-logging-setup*
 675   (log-serialize (make-instance 'logging-setup))
 676   "An empty logging setup; putting this into the logging setup of a
 677   bucket effectively disables logging.")
 678
 679 (defun disable-logging (bucket &key
 680                         ((:credentials *credentials*) *credentials*))
 681   "Disable the creation of access logs for BUCKET."
 682   (submit-request (make-instance 'request
 683                                  :method :put
 684                                  :sub-resource "logging"
 685                                  :bucket bucket
 686                                  :content *empty-logging-setup*)))
 687
 688 (defun logging-setup (bucket &key
 689                       ((:credentials *credentials*) *credentials*))
 690   (let ((setup (setup
 691                 (submit-request (make-instance 'request
 692                                                :bucket bucket
 693                                                :sub-resource "logging")))))
 694     (values (target-bucket setup)
 695             (target-prefix setup)
 696             (target-grants setup))))
 697
 698
 699
 700 ;;; Creating unauthorized and authorized URLs for a resource
 701
 702 (defclass url-based-request (request)
 703   ((expires
 704     :initarg :expires
 705     :accessor expires))
 706   (:default-initargs
 707    :expires 0))
 708
 709 (defmethod date-string ((request url-based-request))
 710   (format nil "~D" (expires request)))
 711
 712 (defun resource-url (&key bucket key vhost ssl sub-resource)
 713   (ecase vhost
 714     (:cname
 715      (format nil "http~@[s~*~]://~A/~@[~A~]~@[?~A~]"
 716              ssl bucket (url-encode key) sub-resource))
 717     (:amazon
 718      (format nil "http~@[s~*~]://~A.s3.amazonaws.com/~@[~A~]~@[?~A~]"
 719              ssl bucket (url-encode key) sub-resource))
 720     ((nil)
 721      (format nil "http~@[s~*~]://s3.amazonaws.com/~@[~A/~]~@[~A~]~@[?~A~]"
 722              ssl (url-encode bucket) (url-encode key) sub-resource))))
 723
 724 (defun authorized-url (&key bucket key vhost expires ssl sub-resource
 725                        ((:credentials *credentials*) *credentials*))
 726   (unless (and expires (integerp expires) (plusp expires))
 727     (error "~S option must be a positive integer" :expires))
 728   (let* ((request (make-instance 'url-based-request
 729                                  :method :get
 730                                  :bucket bucket
 731                                  :sub-resource sub-resource
 732                                  :key key
 733                                  :expires (unix-time expires)))
 734          (parameters
 735           (alist-to-url-encoded-string
 736            (list (cons "AWSAccessKeyId" (access-key *credentials*))
 737                  (cons "Expires" (format nil "~D" (expires request)))
 738                  (cons "Signature"
 739                        (signature request))))))
 740     (case vhost
 741       (:cname
 742        (format nil "http~@[s~*~]://~A/~@[~A~]?~@[~A&~]~A"
 743                ssl bucket (url-encode key) sub-resource parameters))
 744       (:amazon
 745        (format nil "http~@[s~*~]://~A.s3.amazonaws.com/~@[~A~]?~@[~A&~]~A"
 746                ssl bucket (url-encode key) sub-resource parameters))
 747       ((nil)
 748        (format nil "http~@[s~*~]://s3.amazonaws.com/~@[~A/~]~@[~A~]?~@[~A&~]~A"
 749                ssl (url-encode bucket) (url-encode key) sub-resource
 750                    parameters)))))
 751
 752
 753 ;;; Miscellaneous operations
 754
 755 (defparameter *me-cache*
 756   (make-hash-table :test 'equal)
 757   "A cache for the result of the ME function. Keys are Amazon access
 758   key strings.")
 759
 760 (defun me (&key
 761            ((:credentials *credentials*) *credentials*))
 762   "Return a PERSON object corresponding to the current credentials. Cached."
 763   (or (gethash (access-key *credentials*) *me-cache*)
 764       (setf
 765        (gethash (access-key *credentials*) *me-cache*)
 766        (let ((response (submit-request (make-instance 'request))))
 767          (owner response)))))
 768
 769 (defun make-post-policy (&key expires conditions
 770                          ((:credentials *credentials*) *credentials*))
 771   "Return an encoded HTTP POST policy string and policy signature as
 772 multiple values."
 773   (unless expires
 774     (error "~S is required" :expires))
 775   (let ((policy (make-instance 'post-policy
 776                                :expires expires
 777                                :conditions conditions)))
 778     (values (policy-string64 policy)
 779             (policy-signature (secret-key *credentials*) policy))))