2 ;;;; Copyright (c) 2008, 2015 Zachary Beane, All Rights Reserved
4 ;;;; Redistribution and use in source and binary forms, with or without
5 ;;;; modification, are permitted provided that the following conditions
8 ;;;; * Redistributions of source code must retain the above copyright
9 ;;;; notice, this list of conditions and the following disclaimer.
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.
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.
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")))
38 (defun canned-access-policy (access-policy)
39 (let ((value (assoc access-policy
*canned-access-policies
*)))
41 (error "~S is not a supported access policy.~%Supported policies are ~S"
43 (mapcar 'first
*canned-access-policies
*)))
44 (list (cons "acl" (cdr value
)))))
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
))
51 (canned-access-policy :public-read
))
53 (canned-access-policy access-policy
))))
55 (defun head (&key bucket key parameters
56 ((:credentials
*credentials
*) *credentials
*)
57 ((:backoff
*backoff
*) *backoff
*))
58 "Return three values: the HTTP status, an alist of Drakma-style HTTP
59 headers, and the HTTP phrase, with the results of a HEAD request for
60 the object specified by the optional BUCKET and KEY arguments."
61 (let* ((security-token (security-token *credentials
*))
63 (submit-request (make-instance 'request
69 (list (cons "security-token" security-token
)))
70 :parameters parameters
))))
72 (values (http-headers response
)
74 (http-phrase response
))))
76 ;;; Operations on buckets
78 (defun all-buckets (&key
((:credentials
*credentials
*) *credentials
*)
79 ((:backoff
*backoff
*) *backoff
*))
80 "Return a vector of all BUCKET objects associated with *CREDENTIALS*."
81 (let ((response (submit-request (make-instance 'request
85 (defun bucket-location (bucket &key
86 ((:credentials
*credentials
*) *credentials
*)
87 ((:backoff
*backoff
*) *backoff
*))
88 "If BUCKET was created with a LocationConstraint, return its
90 (let* ((request (make-instance 'request
92 :sub-resource
"location"
94 `(,(when (security-token *credentials
*)
95 (cons "x-amz-security-token"
96 (security-token *credentials
*))))
98 (response (submit-request request
))
99 (location (location response
)))
100 (when (plusp (length location
))
103 (defun bucket-region (bucket
104 &key
((:credentials
*credentials
*) *credentials
*)
105 ((:backoff
*backoff
*) *backoff
*))
106 (or (bucket-location bucket
)
109 (defun region-endpoint (region)
110 (if (string= region
"us-east-1")
111 (or *s3-endpoint
* "s3.amazonaws.com")
112 (format nil
"s3-~A.amazonaws.com" region
)))
114 (defun query-bucket (bucket &key prefix marker max-keys delimiter
115 ((:credentials
*credentials
*) *credentials
*)
116 ((:backoff
*backoff
*) *backoff
*))
117 (submit-request (make-instance 'request
125 :delimiter delimiter
))))
127 (defun continue-bucket-query (response)
129 (let ((request (successive-request response
)))
131 (submit-request request
)))))
133 (defun all-keys (bucket &key prefix
134 ((:credentials
*credentials
*) *credentials
*)
135 ((:backoff
*backoff
*) *backoff
*))
136 "Reutrn a vector of all KEY objects in BUCKET."
137 (let ((response (query-bucket bucket
:prefix prefix
))
142 (push (keys response
) results
)
143 (setf response
(continue-bucket-query response
)))
144 (let ((combined (make-array (reduce #'+ results
:key
#'length
)))
146 (dolist (keys (nreverse results
) combined
)
147 (replace combined keys
:start1 start
)
148 (incf start
(length keys
))))))
150 (defun bucket-exists-p (bucket &key
151 ((:credentials
*credentials
*) *credentials
*)
152 ((:backoff
*backoff
*) *backoff
*))
153 (let ((code (nth-value 1 (head :bucket bucket
155 (parameters-alist :max-keys
0)))))
156 (not (<= 400 code
599))))
158 (defun create-bucket (name &key
162 ((:credentials
*credentials
*) *credentials
*)
163 ((:backoff
*backoff
*) *backoff
*))
164 (let ((policy-header (access-policy-header access-policy public
)))
165 (submit-request (make-instance 'request
168 :content
(and location
169 (location-constraint-xml
171 :amz-headers policy-header
))))
173 (defun delete-bucket (bucket &key
174 ((:credentials
*credentials
*) *credentials
*)
175 ((:backoff
*backoff
*) *backoff
*))
176 (let* ((request (make-instance 'request
179 (endpoint (endpoint request
))
180 (bucket (bucket request
)))
182 (submit-request request
)
183 (setf (redirection-data endpoint bucket
) nil
))))
186 ;;; Getting objects as vectors, strings, or files
188 (defun check-request-success (response)
189 (let ((code (http-code response
)))
191 (throw 'not-modified
(values nil
(http-headers response
))))
192 ((not (<= 200 code
299))
193 (setf response
(specialize-response response
))
194 (maybe-signal-error response
)))))
196 (defun make-file-writer-handler (file &key
(if-exists :supersede
))
198 (check-request-success response
)
199 (let ((input (body response
)))
200 (with-open-file (output file
:direction
:output
202 :element-type
'(unsigned-byte 8))
203 (copy-n-octets (content-length response
) input output
)))
204 (setf (body response
) (probe-file file
))
207 (defun vector-writer-handler (response)
208 (check-request-success response
)
209 (let ((buffer (make-octet-vector (content-length response
))))
210 (setf (body response
)
211 (let ((input (body response
)))
212 (read-sequence buffer input
)
216 (defun stream-identity-handler (response)
217 (check-request-success response
)
220 (defun make-string-writer-handler (external-format)
222 (setf response
(vector-writer-handler response
))
223 (setf (body response
)
224 (flexi-streams:octets-to-string
(body response
)
225 :external-format external-format
))
230 (defun get-object (bucket key
&key
232 unless-modified-since
237 (if-exists :supersede
)
238 (string-external-format :utf-8
)
239 ((:credentials
*credentials
*) *credentials
*)
240 ((:backoff
*backoff
*) *backoff
*))
241 (flet ((range-argument (start end
)
243 (format nil
"bytes=~D-~@[~D~]" start
(and end
(1- end
)))))
245 (and time
(http-date-string time
))))
246 (when (and end
(not start
))
248 (when (and start end
(<= end start
))
249 (error "START must be less than END."))
250 (let* ((security-token (security-token *credentials
*))
251 (request (make-instance 'request
257 (list (cons "security-token" security-token
)))
260 ;; nlevine 2016-06-15 -- not only is this apparently
261 ;; unnecessary, it also sends "connection" in the
262 ;; signed headers, which results in a
263 ;; SignatureDoesNotMatch error.
264 ;; :connection (unless *use-keep-alive* "close")
266 (maybe-date when-modified-since
)
268 (maybe-date unless-modified-since
)
269 :if-match when-etag-matches
270 :if-none-match unless-etag-matches
271 :range
(range-argument start end
))))
272 (handler (cond ((eql output
:vector
)
273 'vector-writer-handler
)
274 ((eql output
:string
)
275 (make-string-writer-handler string-external-format
))
276 ((eql output
:stream
)
277 'stream-identity-handler
)
278 ((or (stringp output
)
280 (make-file-writer-handler output
:if-exists if-exists
))
282 (error "Unknown ~S option ~S -- should be ~
283 :VECTOR, :STRING, :STREAM, or a pathname"
287 (let ((response (submit-request request
288 :keep-stream
(or (eql output
:stream
)
292 (values (body response
) (http-headers response
)))
293 (precondition-failed (c)
296 (http-headers (request-error-response c
))))))))))
298 (defun get-vector (bucket key
300 when-modified-since unless-modified-since
301 when-etag-matches unless-etag-matches
302 (if-exists :supersede
)
303 ((:credentials
*credentials
*) *credentials
*)
304 ((:backoff
*backoff
*) *backoff
*))
305 (get-object bucket key
309 :when-modified-since when-modified-since
310 :unless-modified-since unless-modified-since
311 :when-etag-matches when-etag-matches
312 :unless-etag-matches unless-etag-matches
313 :if-exists if-exists
))
315 (defun get-string (bucket key
317 (external-format :utf-8
)
318 when-modified-since unless-modified-since
319 when-etag-matches unless-etag-matches
320 (if-exists :supersede
)
321 ((:credentials
*credentials
*) *credentials
*)
322 ((:backoff
*backoff
*) *backoff
*))
323 (get-object bucket key
325 :string-external-format external-format
328 :when-modified-since when-modified-since
329 :unless-modified-since unless-modified-since
330 :when-etag-matches when-etag-matches
331 :unless-etag-matches unless-etag-matches
332 :if-exists if-exists
))
334 (defun get-file (bucket key file
336 when-modified-since unless-modified-since
337 when-etag-matches unless-etag-matches
338 (if-exists :supersede
)
339 ((:credentials
*credentials
*) *credentials
*)
340 ((:backoff
*backoff
*) *backoff
*))
341 (get-object bucket key
342 :output
(pathname file
)
345 :when-modified-since when-modified-since
346 :unless-modified-since unless-modified-since
347 :when-etag-matches when-etag-matches
348 :unless-etag-matches unless-etag-matches
349 :if-exists if-exists
))
354 (defun format-tagging-header (tagging)
355 (format nil
"~{~a=~a~^&~}"
356 (mapcan #'(lambda (kv)
358 (drakma:url-encode
(car kv
) :iso-8859-1
)
359 (drakma:url-encode
(cdr kv
) :iso-8859-1
)))
362 (defun put-object (object bucket key
&key
366 (string-external-format :utf-8
)
372 (storage-class "STANDARD")
374 ((:credentials
*credentials
*) *credentials
*)
375 ((:backoff
*backoff
*) *backoff
*))
379 (flexi-streams:string-to-octets object
381 string-external-format
))
382 ((or vector pathname
) object
)))
384 (policy-header (access-policy-header access-policy public
))
385 (security-token (security-token *credentials
*)))
386 (setf storage-class
(or storage-class
"STANDARD"))
387 (submit-request (make-instance 'request
393 (append policy-header
395 (list (cons "security-token" security-token
)))
398 (cons "tagging" (format-tagging-header tagging
)))))
401 :cache-control cache-control
402 :content-encoding content-encoding
403 :content-disposition content-disposition
404 :expires
(and expires
405 (http-date-string expires
)))
406 :content-type content-type
407 :content-length content-length
411 (defun put-vector (vector bucket key
&key
419 (content-type "binary/octet-stream")
423 ((:credentials
*credentials
*) *credentials
*)
424 ((:backoff
*backoff
*) *backoff
*))
426 (setf vector
(subseq vector
(or start
0) end
)))
427 (put-object vector bucket key
428 :access-policy access-policy
431 :cache-control cache-control
432 :content-encoding content-encoding
433 :content-disposition content-disposition
434 :content-type content-type
436 :storage-class storage-class
439 (defun put-string (string bucket key
&key
444 (external-format :utf-8
)
448 (content-type "text/plain")
452 ((:credentials
*credentials
*) *credentials
*)
453 ((:backoff
*backoff
*) *backoff
*))
455 (setf string
(subseq string
(or start
0) end
)))
456 (put-object string bucket key
457 :access-policy access-policy
461 :content-disposition content-disposition
462 :content-encoding content-encoding
463 :content-type content-type
464 :cache-control cache-control
465 :string-external-format external-format
466 :storage-class storage-class
470 (defun put-file (file bucket key
&key
478 (content-type "binary/octet-stream")
482 ((:credentials
*credentials
*) *credentials
*)
483 ((:backoff
*backoff
*) *backoff
*))
485 (setf key
(file-namestring file
)))
486 (let ((content (pathname file
)))
488 ;;; FIXME: integrate with not-in-memory file uploading
489 (setf content
(file-subset-vector file start end
)))
490 (put-object content bucket key
491 :access-policy access-policy
494 :cache-control cache-control
495 :content-disposition content-disposition
496 :content-encoding content-encoding
497 :content-type content-type
499 :storage-class storage-class
502 (defun put-stream (stream bucket key
&key
510 (content-type "binary/octet-stream")
514 ((:credentials
*credentials
*) *credentials
*)
515 ((:backoff
*backoff
*) *backoff
*))
516 (let ((content (stream-subset-vector stream start end
)))
517 (put-object content bucket key
518 :access-policy access-policy
521 :cache-control cache-control
522 :content-disposition content-disposition
523 :content-encoding content-encoding
524 :content-type content-type
526 :storage-class storage-class
530 ;;; Delete & copy objects
532 (defun delete-object (bucket key
&key
533 ((:credentials
*credentials
*) *credentials
*)
534 ((:backoff
*backoff
*) *backoff
*))
535 "Delete one object from BUCKET identified by KEY."
536 (let ((security-token (security-token *credentials
*)))
537 (submit-request (make-instance 'request
543 (list (cons "security-token" security-token
)))))))
545 (defun bulk-delete-document (keys)
547 (cxml:with-xml-output
(cxml:make-octet-vector-sink
)
548 (cxml:with-element
"Delete"
551 (cxml:with-element
"Object"
552 (cxml:with-element
"Key"
553 (cxml:text
(name key
)))))
557 (defbinder delete-objects-result
562 ("Key" (bind :deleted-key
)))
564 ("Key" (bind :error-key
))
565 ("Code" (bind :error-code
))
566 ("Message" (bind :error-message
)))))))
568 (defun delete-objects (bucket keys
570 ((:credentials
*credentials
*) *credentials
*)
571 ((:backoff
*backoff
*) *backoff
*))
572 "Delete the objects in BUCKET identified by the sequence KEYS."
575 (subseqs (floor (length keys
) 1000)))
576 (flet ((bulk-delete (keys)
577 (unless (<= 1 (length keys
) 1000)
578 (error "Can only delete 1 to 1000 objects per request ~
581 (let* ((content (bulk-delete-document keys
))
582 (md5 (vector-md5/b64 content
)))
584 (submit-request (make-instance 'request
586 :sub-resource
"delete"
590 (bindings (xml-bind 'delete-objects-result
592 (results (bvalue :results bindings
)))
593 (dolist (result results
(values deleted failed
))
594 (if (bvalue :deleted-key result
)
596 (push result failed
)))))))
597 (loop for start from
0 by
1000
598 for end
= (+ start
1000)
600 (bulk-delete (subseq keys start end
)))
601 (let ((remainder (subseq keys
(* subseqs
1000))))
602 (when (plusp (length remainder
))
603 (bulk-delete (subseq keys
(* subseqs
1000)))))
604 (values deleted failed
))))
606 (defun delete-all-objects (bucket &key
607 ((:credentials
*credentials
*) *credentials
*)
608 ((:backoff
*backoff
*) *backoff
*))
609 "Delete all objects in BUCKET."
610 ;; FIXME: This should probably bucket-query and incrementally delete
611 ;; instead of fetching all keys upfront.
612 (delete-objects bucket
(all-keys bucket
)))
614 (defun copy-object (&key
620 unless-modified-since
621 (metadata nil metadata-supplied-p
)
625 (storage-class "STANDARD")
626 (tagging nil tagging-supplied-p
)
627 ((:credentials
*credentials
*) *credentials
*)
628 ((:backoff
*backoff
*) *backoff
*))
629 "Copy the object identified by FROM-BUCKET/FROM-KEY to
632 If TO-BUCKET is NIL, uses FROM-BUCKET as the target. If TO-KEY is NIL,
633 uses TO-KEY as the target.
635 If METADATA is provided, it should be an alist of metadata keys and
636 values to set on the new object. Otherwise, the source object's
639 If TAGGING is provided, it should be an alist of tag keys and values
640 to be set on the new object's tagging resource. Otherwise, the source
641 object's tagging is copied.
643 Optional precondition variables are WHEN-ETAG-MATCHES,
644 UNLESS-ETAG-MATCHES, WHEN-MODIFIED-SINCE, UNLESS-MODIFIED-SINCE. The
645 etag variables use an etag as produced by the FILE-ETAG function,
646 i.e. a lowercase hex representation of the file's MD5 digest,
647 surrounded by quotes. The modified-since variables should use a
650 If PUBLIC is T, the new object is visible to all
651 users. Otherwise, a default ACL is present on the new object.
654 (error "FROM-BUCKET is required"))
656 (error "FROM-KEY is required"))
657 (setf to-bucket
(or to-bucket from-bucket
))
658 (setf to-key
(or to-key from-key
))
659 (handler-bind ((precondition-failed
661 (unless precondition-errors
662 (return-from copy-object
663 (values nil
(request-error-response condition
)))))))
665 (parameters-alist :copy-source
(format nil
"~A/~A"
666 (url-encode (name from-bucket
))
667 (url-encode (name from-key
)))
668 :storage-class storage-class
670 (if metadata-supplied-p
"REPLACE" "COPY")
672 (if tagging-supplied-p
"REPLACE" "COPY")
673 :copy-source-if-match when-etag-matches
674 :copy-source-if-none-match unless-etag-matches
675 :copy-source-if-modified-since
676 (and when-modified-since
677 (http-date-string when-modified-since
))
678 :copy-source-if-unmodified-since
679 (and unless-modified-since
680 (http-date-string unless-modified-since
))))
681 (policy-header (access-policy-header access-policy public
))
682 (tagging-header (when tagging-supplied-p
683 (list (cons "tagging" (format-tagging-header tagging
))))))
684 (submit-request (make-instance 'request
695 (defun object-metadata (bucket key
697 ((:credentials
*credentials
*) *credentials
*)
698 ((:backoff
*backoff
*) *backoff
*))
699 "Return the metadata headers as an alist, with keywords for the keys."
700 (let* ((prefix "X-AMZ-META-")
701 (plen (length prefix
)))
702 (flet ((metadata-symbol-p (k)
703 (and (< plen
(length (symbol-name k
)))
704 (string-equal k prefix
:end1 plen
)
705 (intern (subseq (symbol-name k
) plen
)
707 (let ((headers (head :bucket bucket
:key key
)))
708 (loop for
((k . value
)) on headers
709 for meta
= (metadata-symbol-p k
)
711 collect
(cons meta value
))))))
714 ;;; Convenience bit for storage class
716 (defun set-storage-class (bucket key storage-class
718 ((:credentials
*credentials
*) *credentials
*)
719 ((:backoff
*backoff
*) *backoff
*))
720 "Set the storage class of the object identified by BUCKET and KEY to
722 (copy-object :from-bucket bucket
:from-key key
723 :storage-class storage-class
))
728 (defparameter *public-read-grant
*
729 (make-instance 'grant
731 :grantee
*all-users
*)
732 "This grant is added to or removed from an ACL to grant or revoke
733 read access for all users.")
735 (defun get-acl (&key bucket key
736 ((:credentials
*credentials
*) *credentials
*)
737 ((:backoff
*backoff
*) *backoff
*))
738 (let* ((request (make-instance 'request
742 :sub-resource
"acl"))
743 (response (submit-request request
))
744 (acl (acl response
)))
748 (defun put-acl (owner grants
&key bucket key
749 ((:credentials
*credentials
*) *credentials
*)
750 ((:backoff
*backoff
*) *backoff
*))
751 (let* ((acl (make-instance 'access-control-list
754 (request (make-instance 'request
759 :content
(acl-serialize acl
))))
760 (submit-request request
)))
763 (defun make-public (&key bucket key
764 ((:credentials
*credentials
*) *credentials
*)
765 ((:backoff
*backoff
*) *backoff
*))
766 (multiple-value-bind (owner grants
)
767 (get-acl :bucket bucket
:key key
)
769 (cons *public-read-grant
* grants
)
773 (defun make-private (&key bucket key
774 ((:credentials
*credentials
*) *credentials
*)
775 ((:backoff
*backoff
*) *backoff
*))
776 (multiple-value-bind (owner grants
)
777 (get-acl :bucket bucket
:key key
)
779 (remove *all-users
* grants
780 :test
#'acl-eqv
:key
#'grantee
))
781 (put-acl owner grants
:bucket bucket
:key key
)))
786 (defparameter *log-delivery-grants
*
787 (list (make-instance 'grant
789 :grantee
*log-delivery
*)
790 (make-instance 'grant
791 :permission
:read-acl
792 :grantee
*log-delivery
*))
793 "This list of grants is used to allow the Amazon log delivery group
794 to write logfile objects into a particular bucket.")
796 (defun enable-logging-to (bucket &key
797 ((:credentials
*credentials
*) *credentials
*)
798 ((:backoff
*backoff
*) *backoff
*))
799 "Configure the ACL of BUCKET to accept logfile objects."
800 (multiple-value-bind (owner grants
)
801 (get-acl :bucket bucket
)
802 (setf grants
(append *log-delivery-grants
* grants
))
803 (put-acl owner grants
:bucket bucket
)))
805 (defun disable-logging-to (bucket &key
806 ((:credentials
*credentials
*) *credentials
*)
807 ((:backoff
*backoff
*) *backoff
*))
808 "Configure the ACL of BUCKET to remove permissions for the log
810 (multiple-value-bind (owner grants
)
811 (get-acl :bucket bucket
)
812 (setf grants
(remove-if (lambda (grant)
813 (acl-eqv (grantee grant
) *log-delivery
*))
815 (put-acl owner grants
:bucket bucket
)))
817 (defun enable-logging (bucket target-bucket target-prefix
820 ((:credentials
*credentials
*) *credentials
*)
821 ((:backoff
*backoff
*) *backoff
*))
822 "Enable logging of requests to BUCKET, putting logfile objects into
823 TARGET-BUCKET with a key prefix of TARGET-PREFIX."
824 (let* ((setup (make-instance 'logging-setup
825 :target-bucket target-bucket
826 :target-prefix target-prefix
827 :target-grants target-grants
))
828 (request (make-instance 'request
830 :sub-resource
"logging"
832 :content
(log-serialize setup
)))
836 (return (submit-request request
))
837 (invalid-logging-target (condition)
838 (when (starts-with "You must give the log-delivery group"
839 (message (request-error-response condition
)))
842 (enable-logging-to target-bucket
))))))))
845 (defparameter *empty-logging-setup
*
846 (log-serialize (make-instance 'logging-setup
))
847 "An empty logging setup; putting this into the logging setup of a
848 bucket effectively disables logging.")
850 (defun disable-logging (bucket &key
851 ((:credentials
*credentials
*) *credentials
*)
852 ((:backoff
*backoff
*) *backoff
*))
853 "Disable the creation of access logs for BUCKET."
854 (submit-request (make-instance 'request
856 :sub-resource
"logging"
858 :content
*empty-logging-setup
*)))
860 (defun logging-setup (bucket &key
861 ((:credentials
*credentials
*) *credentials
*)
862 ((:backoff
*backoff
*) *backoff
*))
864 (submit-request (make-instance 'request
866 :sub-resource
"logging")))))
867 (values (target-bucket setup
)
868 (target-prefix setup
)
869 (target-grants setup
))))
873 ;;; Creating unauthorized and authorized URLs for a resource
875 (defclass url-based-request
(request)
882 (defmethod date-string ((request url-based-request
))
883 (format nil
"~D" (expires request
)))
885 (defun resource-url (&key bucket key vhost ssl sub-resource
)
888 (format nil
"http~@[s~*~]://~A/~@[~A~]~@[?~A~]"
889 ssl bucket
(url-encode key
) sub-resource
))
891 (format nil
"http~@[s~*~]://~A.s3.amazonaws.com/~@[~A~]~@[?~A~]"
892 ssl bucket
(url-encode key
) sub-resource
))
894 (format nil
"http~@[s~*~]://s3.amazonaws.com/~@[~A/~]~@[~A~]~@[?~A~]"
897 (url-encode key
:encode-slash nil
)
900 (defun authorized-url (&key bucket key vhost expires ssl sub-resource content-disposition content-type
901 ((:credentials
*credentials
*) *credentials
*))
902 (unless (and expires
(integerp expires
) (plusp expires
))
903 (error "~S option must be a positive integer" :expires
))
904 (let* ((region (bucket-region bucket
))
905 (region-endpoint (region-endpoint region
))
906 (endpoint (case vhost
908 (:amazon
(format nil
"~A.~A" bucket region-endpoint
))
909 (:wasabi
(format nil
"~a.s3.wasabisys.com" bucket
))
910 ((nil) region-endpoint
)))
911 (extra-parameters (append (if content-disposition
912 (list (cons "response-content-disposition" content-disposition
)))
914 (list (cons "response-content-type" content-type
)))))
915 (request (make-instance 'url-based-request
920 :sub-resource sub-resource
922 :expires
(unix-time expires
)
923 :parameters extra-parameters
)))
924 (setf (amz-headers request
) nil
)
925 (setf (parameters request
)
926 (parameters-alist "X-Amz-Algorithm" "AWS4-HMAC-SHA256"
928 (format nil
"~A/~A/~A/s3/aws4_request"
929 (access-key *credentials
*)
930 (iso8601-basic-date-string (date request
))
932 "X-Amz-Date" (iso8601-basic-timestamp-string (date request
))
933 "X-Amz-Expires" (- expires
(get-universal-time))
934 "X-Amz-SignedHeaders"
935 (format nil
"~{~A~^;~}" (signed-headers request
))))
936 (push (cons "X-Amz-Signature" (request-signature request
))
937 (parameters request
))
938 (let ((parameters (alist-to-url-encoded-string (parameters request
))))
941 (format nil
"http~@[s~*~]://~A/~@[~A~]?~@[~A&~]~A"
944 (url-encode key
:encode-slash nil
)
948 (format nil
"http~@[s~*~]://~A/~@[~A~]?~@[~A&~]~A"
951 (url-encode key
:encode-slash nil
)
955 (format nil
"http~@[s~*~]://~A/~@[~A~]?~@[~A&~]~A"
958 (url-encode key
:encode-slash nil
)
962 (format nil
"http~@[s~*~]://~A/~@[~A/~]~@[~A~]?~@[~A&~]~A"
966 (url-encode key
:encode-slash nil
)
970 ;;; Miscellaneous operations
972 (defparameter *me-cache
*
973 (make-hash-table :test
'equal
)
974 "A cache for the result of the ME function. Keys are Amazon access
978 ((:credentials
*credentials
*) *credentials
*)
979 ((:backoff
*backoff
*) *backoff
*))
980 "Return a PERSON object corresponding to the current credentials. Cached."
981 (or (gethash (access-key *credentials
*) *me-cache
*)
983 (gethash (access-key *credentials
*) *me-cache
*)
984 (let ((response (submit-request (make-instance 'request
))))
987 (defun make-post-policy (&key expires conditions
988 ((:credentials
*credentials
*) *credentials
*))
989 "Return an encoded HTTP POST policy string and policy signature as
992 (error "~S is required" :expires
))
993 (let ((policy (make-instance 'post-policy
995 :conditions conditions
)))
996 (values (policy-string64 policy
)
997 (policy-signature (secret-key *credentials
*) policy
))))
1001 (defbinder get-tagging-result
1007 ("Value" (bind :value
)))))))
1009 (defun get-tagging (&key bucket key
1010 ((:credentials
*credentials
*) *credentials
*)
1011 ((:backoff
*backoff
*) *backoff
*))
1012 "Returns the current contents of the object's tagging resource as an alist."
1013 (let* ((request (make-instance 'request
1017 :sub-resource
"tagging"))
1018 (response (submit-request request
))
1019 (tagging (xml-bind 'get-tagging-result
(body response
))))
1020 (mapcar #'(lambda (tag)
1021 (cons (bvalue :key tag
)
1022 (bvalue :value tag
)))
1023 (bvalue :tag-set tagging
))))
1025 (defun put-tagging (tag-set &key bucket key
1026 ((:credentials
*credentials
*) *credentials
*)
1027 ((:backoff
*backoff
*) *backoff
*))
1028 "Sets the tag set, given as an alist, to the object's tagging resource."
1029 (let* ((content (with-xml-output
1030 (with-element "Tagging"
1031 (with-element "TagSet"
1032 (dolist (tag tag-set
)
1034 (with-element "Key" (cxml:text
(car tag
)))
1035 (with-element "Value" (cxml:text
(cdr tag
)))))))))
1036 (request (make-instance 'request
1040 :sub-resource
"tagging"
1042 (submit-request request
)))
1044 (defun delete-tagging (&key bucket key
1045 ((:credentials
*credentials
*) *credentials
*)
1046 ((:backoff
*backoff
*) *backoff
*))
1047 "Deletes the object's tagging resource."
1048 (let* ((request (make-instance 'request
1052 :sub-resource
"tagging")))
1053 (submit-request request
)))