From 37e0aa424b907ba45cac4eacebb5ff1cc4b10d8d Mon Sep 17 00:00:00 2001 From: Jussi Lahdenniemi Date: Wed, 15 Nov 2017 09:25:08 +0200 Subject: [PATCH] Fixed according to comments, added more tagging related functions. --- doc/index.html | 89 +++++++++++++++++++++++++++++++++++++++++++ interface.lisp | 116 +++++++++++++++++++++++++++++++++++++++++++++------------ package.lisp | 4 ++ 3 files changed, 185 insertions(+), 24 deletions(-) diff --git a/doc/index.html b/doc/index.html index 9cb919e..33ce24a 100644 --- a/doc/index.html +++ b/doc/index.html @@ -1401,6 +1401,7 @@ bucket with the given name. content-type expires storage-class + tagging credentials backoff @@ -1465,6 +1466,11 @@ bucket with the given name. from S3. For more information about reduced redundancy storage, see reduced Redundancy Storage in the Developer Guide. + +

If provided, tagging specifies the set of tags + to be associated with the object. The set is given as an alist. + For more information, see + Object Tagging in the Developer Guide.

@@ -1483,6 +1489,7 @@ bucket with the given name. content-type expires storage-class + tagging credentials backoff @@ -1520,6 +1527,7 @@ bucket with the given name. content-type expires storage-class + tagging credentials backoff @@ -1554,6 +1562,7 @@ calling: content-disposition content-encoding content-type expires storage-class + tagging credentials backoff @@ -1596,6 +1605,7 @@ calling: content-disposition content-encoding content-type expires storage-class + tagging credentials backoff @@ -1645,6 +1655,7 @@ calling: unless-modified-since
metadata public precondition-errors storage-class + tagging credentials backoff @@ -1677,6 +1688,12 @@ calling: means that the new object has no metadata. Otherwise, the metadata is copied from the original object. +

If tagging is explicitly provided, it follows the + same behavior as + with PUT-OBJECT. Passing NIL + means that the new object has no tags. Otherwise, tagging is copied + from the original object. +

If storage-class is provided, it should refer to one of the standard storage classes available for S3; currently the accepted values are the strings "STANDARD" and @@ -2198,6 +2215,78 @@ calling:

+

Object Tagging

 + +

In S3, a set of tags can be associated with each key and + bucket. Tagging offers a way to categorize objects that is + orthogonal to key prefixes. They resemble object metadata but, + unlike metadata, tagging be used in access control, lifecycle + rules, and metrics. For more information, please refer to + the Object + Tagging section on the S3 Developer Guide. + +

+
[Function]
+
+ get-tagging + + &key + bucket + key + credentials + backoff + + => tag-set +
+ +
+

Returns the object's current tag set as an + alist. +

+
+ + +
+
[Function]
+
+ put-tagging + + tag-set + &key + bucket + key + credentials + backoff + + => response +
+ +
+

Sets the object's tagging resource to the given set of tags. + The tags are given as an alist. +

+
+ + +
+
[Function]
+
+ delete-tagging + + &key + bucket + key + credentials + backoff + + => response +
+ +
+

Deletes the tagging resource associated with the object. +

+
+

Miscellaneous Operations

 diff --git a/interface.lisp b/interface.lisp index a987522..d576b1e 100644 --- a/interface.lisp +++ b/interface.lisp @@ -90,10 +90,10 @@ constraint." (let* ((request (make-instance 'request :method :get :sub-resource "location" - :extra-http-headers - `(,(when (security-token *credentials*) - (cons "x-amz-security-token" - (security-token *credentials*)))) + :extra-http-headers + `(,(when (security-token *credentials*) + (cons "x-amz-security-token" + (security-token *credentials*)))) :bucket bucket)) (response (submit-request request)) (location (location response))) @@ -351,6 +351,13 @@ constraint." ;;; Putting objects +(defun format-tagging-header (tagging) + (format nil "~{~a=~a~^&~}" + (mapcan #'(lambda (kv) + (list + (drakma:url-encode (car kv) :iso-8859-1) + (drakma:url-encode (cdr kv) :iso-8859-1))) + tagging))) (defun put-object (object bucket key &key access-policy @@ -363,7 +370,7 @@ constraint." expires content-type (storage-class "STANDARD") - tags + tagging ((:credentials *credentials*) *credentials*) ((:backoff *backoff*) *backoff*)) (let ((content @@ -386,15 +393,9 @@ constraint." (append policy-header (when security-token (list (cons "security-token" security-token))) - (when tags - (list - (cons "tagging" - (format nil "~{~a=~a~^&~}" - (mapcan #'(lambda (kv) - (list - (drakma:url-encode (car kv) :iso-8859-1) - (drakma:url-encode (cdr kv) :iso-8859-1))) - tags)))))) + (when tagging + (list + (cons "tagging" (format-tagging-header tagging))))) :extra-http-headers (parameters-alist :cache-control cache-control @@ -418,7 +419,7 @@ constraint." (content-type "binary/octet-stream") expires storage-class - tags + tagging ((:credentials *credentials*) *credentials*) ((:backoff *backoff*) *backoff*)) (when (or start end) @@ -433,7 +434,7 @@ constraint." :content-type content-type :expires expires :storage-class storage-class - :tags tags)) + :tagging tagging)) (defun put-string (string bucket key &key start end @@ -447,7 +448,7 @@ constraint." (content-type "text/plain") expires storage-class - tags + tagging ((:credentials *credentials*) *credentials*) ((:backoff *backoff*) *backoff*)) (when (or start end) @@ -463,7 +464,7 @@ constraint." :cache-control cache-control :string-external-format external-format :storage-class storage-class - :tags tags)) + :tagging tagging)) (defun put-file (file bucket key &key @@ -477,7 +478,7 @@ constraint." (content-type "binary/octet-stream") expires storage-class - tags + tagging ((:credentials *credentials*) *credentials*) ((:backoff *backoff*) *backoff*)) (when (eq key t) @@ -496,7 +497,7 @@ constraint." :content-type content-type :expires expires :storage-class storage-class - :tags tags))) + :tagging tagging))) (defun put-stream (stream bucket key &key (start 0) end @@ -509,7 +510,7 @@ constraint." (content-type "binary/octet-stream") expires storage-class - tags + tagging ((:credentials *credentials*) *credentials*) ((:backoff *backoff*) *backoff*)) (let ((content (stream-subset-vector stream start end))) @@ -523,7 +524,7 @@ constraint." :content-type content-type :expires expires :storage-class storage-class - :tags tags))) + :tagging tagging))) ;;; Delete & copy objects @@ -622,6 +623,7 @@ constraint." public precondition-errors (storage-class "STANDARD") + (tagging nil tagging-supplied-p) ((:credentials *credentials*) *credentials*) ((:backoff *backoff*) *backoff*)) "Copy the object identified by FROM-BUCKET/FROM-KEY to @@ -634,6 +636,10 @@ If METADATA is provided, it should be an alist of metadata keys and values to set on the new object. Otherwise, the source object's metadata is copied. +If TAGGING is provided, it should be an alist of tag keys and values +to be set on the new object's tagging resource. Otherwise, the source +object's tagging is copied. + Optional precondition variables are WHEN-ETAG-MATCHES, UNLESS-ETAG-MATCHES, WHEN-MODIFIED-SINCE, UNLESS-MODIFIED-SINCE. The etag variables use an etag as produced by the FILE-ETAG function, @@ -662,6 +668,8 @@ users. Otherwise, a default ACL is present on the new object. :storage-class storage-class :metadata-directive (if metadata-supplied-p "REPLACE" "COPY") + :tagging-directive + (if tagging-supplied-p "REPLACE" "COPY") :copy-source-if-match when-etag-matches :copy-source-if-none-match unless-etag-matches :copy-source-if-modified-since @@ -670,14 +678,18 @@ users. Otherwise, a default ACL is present on the new object. :copy-source-if-unmodified-since (and unless-modified-since (http-date-string unless-modified-since)))) - (policy-header (access-policy-header access-policy public))) + (policy-header (access-policy-header access-policy public)) + (tagging-header (when tagging-supplied-p + (list (cons "tagging" (format-tagging-header tagging)))))) (submit-request (make-instance 'request :method :put :bucket to-bucket :key to-key :metadata metadata :amz-headers - (nconc headers policy-header)))))) + (nconc headers + policy-header + tagging-header)))))) (defun object-metadata (bucket key @@ -971,3 +983,59 @@ multiple values." :conditions conditions))) (values (policy-string64 policy) (policy-signature (secret-key *credentials*) policy)))) + +;;; Tagging + +(defbinder get-tagging-result + ("Tagging" + ("TagSet" + (sequence :tag-set + ("Tag" + ("Key" (bind :key)) + ("Value" (bind :value))))))) + +(defun get-tagging (&key bucket key + ((:credentials *credentials*) *credentials*) + ((:backoff *backoff*) *backoff*)) + "Returns the current contents of the object's tagging resource as an alist." + (let* ((request (make-instance 'request + :method :get + :bucket bucket + :key key + :sub-resource "tagging")) + (response (submit-request request)) + (tagging (xml-bind 'get-tagging-result (body response)))) + (mapcar #'(lambda (tag) + (cons (bvalue :key tag) + (bvalue :value tag))) + (bvalue :tag-set tagging)))) + +(defun put-tagging (tag-set &key bucket key + ((:credentials *credentials*) *credentials*) + ((:backoff *backoff*) *backoff*)) + "Sets the tag set, given as an alist, to the object's tagging resource." + (let* ((content (with-xml-output + (with-element "Tagging" + (with-element "TagSet" + (dolist (tag tag-set) + (with-element "Tag" + (with-element "Key" (cxml:text (car tag))) + (with-element "Value" (cxml:text (cdr tag))))))))) + (request (make-instance 'request + :method :put + :bucket bucket + :key key + :sub-resource "tagging" + :content content))) + (submit-request request))) + +(defun delete-tagging (&key bucket key + ((:credentials *credentials*) *credentials*) + ((:backoff *backoff*) *backoff*)) + "Deletes the object's tagging resource." + (let* ((request (make-instance 'request + :method :delete + :bucket bucket + :key key + :sub-resource "tagging"))) + (submit-request request))) diff --git a/package.lisp b/package.lisp index c76255d..652146e 100644 --- a/package.lisp +++ b/package.lisp @@ -104,6 +104,10 @@ #:enable-logging #:disable-logging #:logging-setup) + ;; Tagging + (:export #:get-tagging + #:put-tagging + #:delete-tagging) ;; Misc. (:export #:*use-ssl* #:*use-keep-alive* -- 2.11.4.GIT