interface.lisp

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