From a496ac3a96d4b79e105264ddd11e1fc595ae0b90 Mon Sep 17 00:00:00 2001 From: Zach Beane Date: Fri, 17 Jun 2016 10:11:58 -0400 Subject: [PATCH] Support keep-alives and security tokens. Thanks to Nick Levine for the patch, lightly modified and documented by me. --- credentials.lisp | 19 ++++++++-- doc/index.html | 47 ++++++++++++++++++++++++ interface.lisp | 107 +++++++++++++++++++++++++++++++------------------------ package.lisp | 8 ++--- request.lisp | 40 ++++++++++++++++++--- response.lisp | 38 +++++++++++++++----- 6 files changed, 193 insertions(+), 66 deletions(-) diff --git a/credentials.lisp b/credentials.lisp index 11a3e8f..dd60893 100644 --- a/credentials.lisp +++ b/credentials.lisp @@ -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 @@ -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 @@ -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 @@ -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 diff --git a/doc/index.html b/doc/index.html index eb523e0..57a0700 100644 --- a/doc/index.html +++ b/doc/index.html @@ -320,6 +320,23 @@ ZS3.
+
[Function]
+
+ security-token + + credentials + + => security-token-string +
+ +
+

Returns the security token string for credentials, + or NIL if there is no associated security token.

+
+
+ + +
[Generic function]
secret-key @@ -2030,6 +2047,36 @@ calling:
+
+
[Special variable]
+
+ *use-keep-alive* +
+ +
+

When true, HTTP keep-alives are used to reuse a single + network connection for multiple requests.

+
+
+ +
+
[Macro]
+
+ with-keep-alive + + &body body + + => | +
+ +
+

Evaluate body in a context + where *USE-KEEP-ALIVE* + is true. +

+
+ +
[Function]
diff --git a/interface.lisp b/interface.lisp index 2fcb54c..8b137e9 100644 --- a/interface.lisp +++ b/interface.lisp @@ -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 @@ -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)) @@ -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)) @@ -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))))) @@ -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))) @@ -341,7 +351,9 @@ 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 @@ -349,9 +361,8 @@ constraint." :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 @@ -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 diff --git a/package.lisp b/package.lisp index b08ec9b..4252048 100644 --- a/package.lisp +++ b/package.lisp @@ -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 @@ -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* @@ -171,6 +174,3 @@ #:text #:attribute #:attribute*)) - - - diff --git a/request.lisp b/request.lisp index 12f0a00..3a40109 100644 --- a/request.lisp +++ b/request.lisp @@ -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 @@ -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 @@ -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) @@ -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))) diff --git a/response.lisp b/response.lisp index c24b816..5821fc6 100644 --- a/response.lisp +++ b/response.lisp @@ -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 @@ -29,6 +29,7 @@ (in-package #:zs3) + (defvar *response-element-classes* (make-hash-table :test 'equal)) @@ -82,7 +83,7 @@ (defgeneric specialize-response (response) (:method ((response response)) (cond ((or (null (body response)) - (and (not (streamp (body response))) + (and (not (streamp (body response))) (zerop (length (body response))))) response) (t @@ -94,6 +95,13 @@ (specialized-initialize response source)) response))))) + +(defun close-keep-alive () + (when *keep-alive-stream* + (ignore-errors (close *keep-alive-stream*)) + (setq *keep-alive-stream* nil))) + + (defun request-response (request &key body-stream keep-stream @@ -103,8 +111,9 @@ (ensure-amz-header request "date" (iso8601-basic-timestamp-string (date request))) (multiple-value-bind (body code headers uri stream must-close phrase) - (send request :want-stream body-stream) - (declare (ignore uri must-close)) + (send request :want-stream body-stream + :stream *keep-alive-stream*) + (declare (ignore uri)) (let ((response (make-instance 'response :request request @@ -112,13 +121,21 @@ :http-code code :http-phrase phrase :http-headers headers))) - (if keep-stream - (funcall handler response) + (if (and keep-stream (not must-close)) + (progn + (when *use-keep-alive* + (unless (eq *keep-alive-stream* stream) + (close-keep-alive) + (setq *keep-alive-stream* stream))) + (funcall handler response)) (with-open-stream (stream stream) + (declare (ignorable stream)) + (setq *keep-alive-stream* nil) (funcall handler response)))))) (defun submit-request (request - &key body-stream keep-stream + &key body-stream + (keep-stream *use-keep-alive*) (handler 'specialize-response)) ;; The original endpoint has to be stashed so it can be updated as ;; needed by AuthorizationHeaderMalformed responses after being @@ -155,4 +172,9 @@ (setf (region request) new-region)))) (internal-error () ;; Per the S3 docs, InternalErrors should simply be retried - ))))) + (close-keep-alive)) + (error (e) + ;; Ensure that we don't reuse the stream, it may be the source of + ;; our error. Then resignal. + (close-keep-alive) + (error e)))))) -- 2.11.4.GIT