Skip to content

Commit

Permalink
Fixed according to comments, added more tagging related functions.
Browse files Browse the repository at this point in the history
  • Loading branch information
@jlahd
jlahd committed Nov 15, 2017
1 parent e87d2d9 commit 37e0aa4
Show file tree
Hide file tree
Showing 3 changed files with 185 additions and 24 deletions.
89 changes: 89 additions & 0 deletions doc/index.html
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1401,6 +1401,7 @@ <h2>Contents</h2>
<var>content-type</var>
<var>expires</var>
<var>storage-class</var>
<var>tagging</var>
<var>credentials</var>
<var>backoff</var>
</span>
Expand Down Expand Up @@ -1465,6 +1466,11 @@ <h2>Contents</h2>
from S3. For more information about reduced redundancy storage,
see <a href="http://docs.aws.amazon.com/AmazonS3/latest/dev/Introduction.html#RRS">reduced
Redundancy Storage</a> in the Developer Guide.

<p>If provided, <var>tagging</var> specifies the set of tags
to be associated with the object. The set is given as an alist.
For more information, see <a href="http://docs.aws.amazon.com/AmazonS3/latest/dev/object-tagging.html">
Object Tagging</a> in the Developer Guide.
</div>

<div class='item'>
Expand All @@ -1483,6 +1489,7 @@ <h2>Contents</h2>
<var>content-type</var>
<var>expires</var>
<var>storage-class</var>
<var>tagging</var>
<var>credentials</var>
<var>backoff</var>
</span>
Expand Down Expand Up @@ -1520,6 +1527,7 @@ <h2>Contents</h2>
<var>content-type</var>
<var>expires</var>
<var>storage-class</var>
<var>tagging</var>
<var>credentials</var>
<var>backoff</var>
</span>
Expand Down Expand Up @@ -1554,6 +1562,7 @@ <h2>Contents</h2>
<var>content-disposition</var> <var>content-encoding</var> <var>content-type</var>
<var>expires</var>
<var>storage-class</var>
<var>tagging</var>
<var>credentials</var>
<var>backoff</var>
</span>
Expand Down Expand Up @@ -1596,6 +1605,7 @@ <h2>Contents</h2>
<var>content-disposition</var> <var>content-encoding</var> <var>content-type</var>
<var>expires</var>
<var>storage-class</var>
<var>tagging</var>
<var>credentials</var>
<var>backoff</var>
</span>
Expand Down Expand Up @@ -1645,6 +1655,7 @@ <h2>Contents</h2>
<var>unless-modified-since</var> <br>
<var>metadata</var> <var>public</var> <var>precondition-errors</var>
<var>storage-class</var>
<var>tagging</var>
<var>credentials</var>
<var>backoff</var>
</span>
Expand Down Expand Up @@ -1677,6 +1688,12 @@ <h2>Contents</h2>
means that the new object has no metadata. Otherwise, the metadata
is copied from the original object.

<p>If <var>tagging</var> is explicitly provided, it follows the
same behavior as
with <a href='#put-object'><tt>PUT-OBJECT</tt></a>. Passing NIL
means that the new object has no tags. Otherwise, tagging is copied
from the original object.

<p>If <var>storage-class</var> is provided, it should refer to one
of the standard storage classes available for S3; currently the
accepted values are the strings "STANDARD" and
Expand Down Expand Up @@ -2198,6 +2215,78 @@ <h2>Contents</h2>
</blockquote>
</div>

<a name='tagging'><h3>Object Tagging</h3></a>

<p>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 <a href="http://docs.aws.amazon.com/AmazonS3/latest/dev/object-tagging.html">Object
Tagging</a> section on the S3 Developer Guide.

<div class='item'>
<div class='type'><a name='get-tagging'>[Function]</a></div>
<div class='signature'>
<code class='name'>get-tagging</code>
<span class='args'>
<code class='llkw'>&amp;key</code>
<var>bucket</var>
<var>key</var>
<var>credentials</var>
<var>backoff</var>
</span>
<span class='result'>=> <var>tag-set</var></span>
</div>

<blockquote class='description'>
<p>Returns the object's current tag set as an
alist.
</blockquote>
</div>


<div class='item'>
<div class='type'><a name='put-tagging'>[Function]</a></div>
<div class='signature'>
<code class='name'>put-tagging</code>
<span class='args'>
<var>tag-set</var>
<code class='llkw'>&amp;key</code>
<var>bucket</var>
<var>key</var>
<var>credentials</var>
<var>backoff</var>
</span>
<span class='result'>=> <var>response</var></span>
</div>

<blockquote class='description'>
<p>Sets the object's tagging resource to the given set of tags.
The tags are given as an alist.
</blockquote>
</div>


<div class='item'>
<div class='type'><a name='delete-tagging'>[Function]</a></div>
<div class='signature'>
<code class='name'>delete-tagging</code>
<span class='args'>
<code class='llkw'>&amp;key</code>
<var>bucket</var>
<var>key</var>
<var>credentials</var>
<var>backoff</var>
</span>
<span class='result'>=> <var>response</var></span>
</div>

<blockquote class='description'>
<p>Deletes the tagging resource associated with the object.
</blockquote>
</div>


<a name='misc'><h3>Miscellaneous Operations</h3></a>

Expand Down
116 changes: 92 additions & 24 deletions interface.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)))
Expand Down Expand Up @@ -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
Expand All @@ -363,7 +370,7 @@ constraint."
expires
content-type
(storage-class "STANDARD")
tags
tagging
((:credentials *credentials*) *credentials*)
((:backoff *backoff*) *backoff*))
(let ((content
Expand All @@ -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
Expand All @@ -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)
Expand All @@ -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
Expand All @@ -447,7 +448,7 @@ constraint."
(content-type "text/plain")
expires
storage-class
tags
tagging
((:credentials *credentials*) *credentials*)
((:backoff *backoff*) *backoff*))
(when (or start end)
Expand All @@ -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
Expand All @@ -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)
Expand All @@ -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
Expand All @@ -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)))
Expand All @@ -523,7 +524,7 @@ constraint."
:content-type content-type
:expires expires
:storage-class storage-class
:tags tags)))
:tagging tagging)))


;;; Delete & copy objects
Expand Down Expand Up @@ -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
Expand All @@ -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,
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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)))
Loading

0 comments on commit 37e0aa4

Please sign in to comment.