Skip to content

Commit

Permalink
Support keep-alives and security tokens.
Browse files Browse the repository at this point in the history 
Thanks to Nick Levine for the patch, lightly modified and documented by
me.
  • Loading branch information
@xach
xach committed Jun 17, 2016
1 parent ac81d88 commit a496ac3
Show file tree
Hide file tree
Showing 6 changed files with 193 additions and 66 deletions.
19 changes: 16 additions & 3 deletions credentials.lisp
View file
Original file line number Diff line number Diff line change
@@ -1,5 +1,5 @@
;;;;
;;;; Copyright (c) 2008 Zachary Beane, All Rights Reserved
;;;; Copyright (c) 2008, 2015 Zachary Beane, All Rights Reserved
;;;;
;;;; Redistribution and use in source and binary forms, with or without
;;;; modification, are permitted provided that the following conditions
Expand Down Expand Up @@ -55,6 +55,12 @@ request.")
(:method ((list cons))
(second list)))

(defgeneric security-token (credentials)
(:method ((object t))
nil)
(:method ((list cons))
(third list)))


;;; Lazy-loading credentials

Expand All @@ -68,6 +74,10 @@ request.")
(slot (eql 'secret-key)))
(nth-value 1 (initialize-lazy-credentials credentials)))

(defmethod slot-unbound ((class t) (credentials lazy-credentials-mixin)
(slot (eql 'security-token)))
(nth-value 2 (initialize-lazy-credentials credentials)))


;;; Loading credentials from a file

Expand All @@ -78,13 +88,16 @@ request.")
(access-key
:accessor access-key)
(secret-key
:accessor secret-key)))
:accessor secret-key)
(security-token
:accessor security-token)))

(defgeneric initialize-lazy-credentials (credentials)
(:method ((credentials file-credentials))
(with-open-file (stream (file credentials))
(values (setf (access-key credentials) (read-line stream))
(setf (secret-key credentials) (read-line stream))))))
(setf (secret-key credentials) (read-line stream))
(setf (security-token credentials) (read-line stream nil))))))

(defun file-credentials (file)
(make-instance 'file-credentials
Expand Down
47 changes: 47 additions & 0 deletions doc/index.html
View file
Original file line number Diff line number Diff line change
Expand Up @@ -319,6 +319,23 @@ <h2>Contents</h2>
</div>


<div class='item'>
<div class='type'><a name='security-token'>[Function]</a></div>
<div class='signature'>
<code class='name'>security-token</code>
<span class='args'>
<var>credentials</var>
</span>
<span class='result'>=> <var>security-token-string</var></span>
</div>

<blockquote class='description'>
<p>Returns the security token string for <var>credentials</var>,
or NIL if there is no associated security token.</p>
</blockquote>
</div>


<div class='item'>
<div class='type'><a name='secret-key'>[Generic function]</a></div>
<div class='signature'>
Expand Down Expand Up @@ -2030,6 +2047,36 @@ <h2>Contents</h2>
</blockquote>
</div>

<div class='item'>
<div class='type'><a name='*use-keep-alive*'>[Special variable]</a></div>
<div class='signature'>
<code class='name'>*use-keep-alive*</code>
</div>

<blockquote class='description'>
<p>When <i>true</i>, HTTP keep-alives are used to reuse a single
network connection for multiple requests.</p>
</blockquote>
</div>

<div class='item'>
<div class='type'><a name='with-keep-alive'>[Macro]</a></div>
<div class='signature'>
<code class='name'>with-keep-alive</code>
<span class='args'>
<code class='llkw'>&amp;body</code> <var>body</var>
</span>
<span class='result'>=> |</span>
</div>

<blockquote class='description'>
<p>Evaluate <var>body</var> in a context
where <a href='#*use-keep-alive*'><tt>*USE-KEEP-ALIVE*</tt></a>
is <i>true</i>.
</blockquote>
</div>



<div class='item'>
<div class='type'><a name='make-post-policy'>[Function]</a></div>
Expand Down
107 changes: 61 additions & 46 deletions interface.lisp
View file
Original file line number Diff line number Diff line change
@@ -1,5 +1,5 @@
;;;;
;;;; Copyright (c) 2008 Zachary Beane, All Rights Reserved
;;;; Copyright (c) 2008, 2015 Zachary Beane, All Rights Reserved
;;;;
;;;; Redistribution and use in source and binary forms, with or without
;;;; modification, are permitted provided that the following conditions
Expand Down Expand Up @@ -179,7 +179,7 @@ constraint."
(defun make-file-writer-handler (file &key (if-exists :supersede))
(lambda (response)
(check-request-success response)
(with-open-stream (input (body response))
(let ((input (body response)))
(with-open-file (output file :direction :output
:if-exists if-exists
:element-type '(unsigned-byte 8))
Expand All @@ -191,7 +191,7 @@ constraint."
(check-request-success response)
(let ((buffer (make-octet-vector (content-length response))))
(setf (body response)
(with-open-stream (input (body response))
(let ((input (body response)))
(read-sequence buffer input)
buffer))
response))
Expand All @@ -211,15 +211,15 @@ constraint."


(defun get-object (bucket key &key
when-modified-since
unless-modified-since
when-etag-matches
unless-etag-matches
start end
(output :vector)
(if-exists :supersede)
(string-external-format :utf-8)
((:credentials *credentials*) *credentials*))
when-modified-since
unless-modified-since
when-etag-matches
unless-etag-matches
start end
(output :vector)
(if-exists :supersede)
(string-external-format :utf-8)
((:credentials *credentials*) *credentials*))
(flet ((range-argument (start end)
(when start
(format nil "bytes=~D-~@[~D~]" start (and end (1- end)))))
Expand All @@ -229,36 +229,46 @@ constraint."
(setf start 0))
(when (and start end (<= end start))
(error "START must be less than END."))
(let ((request (make-instance 'request
:method :get
:bucket bucket
:key key
:extra-http-headers
(parameters-alist
:if-modified-since
(maybe-date when-modified-since)
:if-unmodified-since
(maybe-date unless-modified-since)
:if-match when-etag-matches
:if-none-match unless-etag-matches
:range (range-argument start end))))
(handler (cond ((eql output :vector)
'vector-writer-handler)
((eql output :string)
(make-string-writer-handler string-external-format))
((eql output :stream)
'stream-identity-handler)
((or (stringp output)
(pathnamep output))
(make-file-writer-handler output :if-exists if-exists))
(t
(error "Unknown ~S option ~S -- should be ~
(let* ((security-token (security-token *credentials*))
(request (make-instance 'request
:method :get
:bucket bucket
:key key
:amz-headers
(when security-token
(list (cons "security-token" security-token)))
:extra-http-headers
(parameters-alist
;; nlevine 2016-06-15 -- not only is this apparently
;; unnecessary, it also sends "connection" in the
;; signed headers, which results in a
;; SignatureDoesNotMatch error.
;; :connection (unless *use-keep-alive* "close")
:if-modified-since
(maybe-date when-modified-since)
:if-unmodified-since
(maybe-date unless-modified-since)
:if-match when-etag-matches
:if-none-match unless-etag-matches
:range (range-argument start end))))
(handler (cond ((eql output :vector)
'vector-writer-handler)
((eql output :string)
(make-string-writer-handler string-external-format))
((eql output :stream)
'stream-identity-handler)
((or (stringp output)
(pathnamep output))
(make-file-writer-handler output :if-exists if-exists))
(t
(error "Unknown ~S option ~S -- should be ~
:VECTOR, :STRING, :STREAM, or a pathname"
:output output)))))
(catch 'not-modified
(handler-case
(let ((response (submit-request request
:keep-stream (eql output :stream)
:keep-stream (or (eql output :stream)
*use-keep-alive*)
:body-stream t
:handler handler)))
(values (body response) (http-headers response)))
Expand Down Expand Up @@ -341,17 +351,18 @@ constraint."
string-external-format))
((or vector pathname) object)))
(content-length t)
(policy-header (access-policy-header access-policy public)))
(policy-header (access-policy-header access-policy public))
(security-token (security-token *credentials*)))
(declare (ignore policy-header))
(setf storage-class (or storage-class "STANDARD"))
(submit-request (make-instance 'request
:method :put
:bucket bucket
:key key
:metadata metadata
:amz-headers
(append policy-header
(list (cons "storage-class"
storage-class)))
(when security-token
(list (cons "security-token" security-token)))
:extra-http-headers
(parameters-alist
:cache-control cache-control
Expand Down Expand Up @@ -474,12 +485,16 @@ constraint."
;;; Delete & copy objects

(defun delete-object (bucket key &key
((:credentials *credentials*) *credentials*))
((:credentials *credentials*) *credentials*))
"Delete one object from BUCKET identified by KEY."
(submit-request (make-instance 'request
:method :delete
:bucket bucket
:key key)))
(let ((security-token (security-token *credentials*)))
(submit-request (make-instance 'request
:method :delete
:bucket bucket
:key key
:amz-headers
(when security-token
(list (cons "security-token" security-token)))))))

(defun bulk-delete-document (keys)
(coerce
Expand Down
8 changes: 4 additions & 4 deletions package.lisp
View file
Original file line number Diff line number Diff line change
@@ -1,5 +1,5 @@
;;;;
;;;; Copyright (c) 2008 Zachary Beane, All Rights Reserved
;;;; Copyright (c) 2008, 2015 Zachary Beane, All Rights Reserved
;;;;
;;;; Redistribution and use in source and binary forms, with or without
;;;; modification, are permitted provided that the following conditions
Expand Down Expand Up @@ -100,6 +100,9 @@
#:logging-setup)
;; Misc.
(:export #:*use-ssl*
#:*use-keep-alive*
#:*keep-alive-stream*
#:with-keep-alive
#:*s3-endpoint*
#:*s3-region*
#:*use-content-md5*
Expand Down Expand Up @@ -171,6 +174,3 @@
#:text
#:attribute
#:attribute*))



40 changes: 35 additions & 5 deletions request.lisp
View file
Original file line number Diff line number Diff line change
@@ -1,5 +1,5 @@
;;;;
;;;; Copyright (c) 2008 Zachary Beane, All Rights Reserved
;;;; Copyright (c) 2008, 2015 Zachary Beane, All Rights Reserved
;;;;
;;;; Redistribution and use in source and binary forms, with or without
;;;; modification, are permitted provided that the following conditions
Expand Down Expand Up @@ -37,6 +37,32 @@
"When true, compute the SHA256 hash for the body of all requests
when submitting to AWS.")

(defvar *use-keep-alive* nil
"When set to t, this library uses the drakma client with
keep alive enabled. This means that a stream will be reused for multiple
requests. The stream itself will be bound to *keep-alive-stream*")


(defvar *keep-alive-stream* nil
"When using http keep-alive, this variable is bound to the stream
which is being kept open for repeated usage. It is up to client code
to ensure that only one thread at a time is making requests that
could use the same stream object concurrently. One way to achive
this would be to create a separate binding per thread. The
with-keep-alive macro can be useful here.")


(defmacro with-keep-alive (&body body)
"Create thread-local bindings of the zs3 keep-alive variables around a
body of code. Ensure the stream is closed at exit."
`(let ((*use-keep-alive* t)
(*keep-alive-stream* nil))
(unwind-protect
(progn ,@body)
(when *keep-alive-stream*
(ignore-errors (close *keep-alive-stream*))))))


(defclass request ()
((credentials
:initarg :credentials
Expand Down Expand Up @@ -395,13 +421,15 @@ service. A signing key could be saved, shared, and reused, but ZS3 just recomput
(read-exactly rest)
(funcall fun (subseq buffer 0 rest) nil))))))

(defgeneric send (request &key want-stream)
(:method (request &key want-stream)
(defgeneric send (request &key want-stream stream)
(:method (request &key want-stream stream)
(let ((continuation
(drakma:http-request (url request)
:close t
:redirect nil
:want-stream want-stream
:stream stream
:keep-alive *use-keep-alive*
:close (not *use-keep-alive*)
:content-type (content-type request)
:additional-headers (drakma-headers request)
:method (method request)
Expand All @@ -413,10 +441,12 @@ service. A signing key could be saved, shared, and reused, but ZS3 just recomput
(if (pathnamep content)
(send-file-content continuation request)
(funcall continuation content nil))))))

(defmethod access-key ((request request))
(access-key (credentials request)))

(defmethod secret-key ((request request))
(secret-key (credentials request)))

(defmethod security-token ((request request))
(security-token (credentials request)))
Loading

0 comments on commit a496ac3

Please sign in to comment.