Removing deprecated with-bucket.

Thanks to Seth Alves for reporting the bug and providing a patch.

LICENSE

@@ -0,0 +1,22 @@
+Copyright (c) 2011-2013, Thomas Hintz
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met: 
+
+1. Redistributions of source code must retain the above copyright notice, this
+   list of conditions and the following disclaimer. 
+2. Redistributions in binary form must reproduce the above copyright notice,
+   this list of conditions and the following disclaimer in the documentation
+   and/or other materials provided with the distribution. 
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

amazon-s3.release-info

@@ -5,3 +5,6 @@
 (release "2")
 (release "3")
 (release "4")
+(release "5")
+(release "6")
+(release "7")

amazon-s3.scm

@@ -11,7 +11,7 @@
 
    ;; procs
    list-objects list-buckets bucket-exists? create-bucket! delete-bucket! get-object put-object! delete-object!
-   put-string! put-sexp! get-string get-sexp
+   put-string! put-sexp! put-file! get-string get-sexp get-file
 
    ;; macros
    with-bucket)
@@ -61,11 +61,11 @@
                          (if date (display date) (display ""))
                          (newline)
                          (display (fold (lambda (e o)
-                                        (string-append o (sprintf "~a:~a~%" (car e) (cdr e))))
+					  (string-append o (sprintf "~a:~a~%" (car e) (cdr e))))
-                                      ""
+					""
-                                      can-amz-headers))
+					can-amz-headers))
                          (display resource))))
-         (hmac-sha1 (base64-encode ((hmac (secret-key) (sha1-primitive)) can-string))))
+	 (hmac-sha1 (base64-encode ((hmac (secret-key) (sha1-primitive)) can-string))))
     (set! *last-sig* can-string)
     (values hmac-sha1 can-string)))
 
@@ -103,32 +103,54 @@
                              (bucket #f)
                              (path #f)
                              (sxpath '())
-                             (body '())
+                             (body "")
                              (verb "GET")
                              (ns '((x . "http://s3.amazonaws.com/doc/2006-03-01/")))
                              (no-xml #f)
                              (no-auth #f)
+			     (reader-thunk read-string)
                              (content-type "application/x-www-form-urlencoded")
                              (content-length 0))
-  ;(handle-exceptions
-  ; exn
-  ; ((condition-property-accessor 'client-error 'body) exn)
   (with-input-from-request
    (aws-request bucket path verb no-auth: no-auth content-type: content-type content-length: content-length)
    body
    (if no-xml
-       read-string
+       reader-thunk
        (aws-xml-parser sxpath ns))))
 
-;;; api
+(define (read-byte-file path . port)
+  (lambda ()
+    (let ((file (open-input-file path)))
+      (letrec ((read-next
+		(lambda ()
+		  (let ((b (read-byte file)))
+		    (if (eof-object? b)
+			#t
+			(begin 
+			  (if (> (length port) 0)
+			      (write-byte b (car port))
+			      (write-byte b))
+			  (read-next)))))))
+	(read-next))
+      (close-input-port file))))
 
-(define-syntax with-bucket
+(define (write-byte-file path . port)
-  (syntax-rules ()
+  (lambda ()
-    ((with-bucket bucket (func p1 ...))
+    (let ((file (open-output-file path)))
-     (func bucket p1 ...))
+      (letrec ((read-next
-    ((with-bucket bucket exp body ...)
+		(lambda ()
-     (begin (with-bucket bucket exp)
+		  (let ((b (if (> (length port) 0)
-            (with-bucket bucket body ...)))))
+			       (read-byte (car port))
+			       (read-byte))))
+		    (if (eof-object? b)
+			#t
+			(begin 
+			  (write-byte b file)
+			  (read-next)))))))
+	(read-next))
+      (close-output-port file))))
+
+;;; api
 
 (define (list-buckets)
   (perform-aws-request sxpath: '(x:ListAllMyBucketsResult x:Buckets x:Bucket x:Name *text*)))
@@ -150,16 +172,19 @@
   (perform-aws-request bucket: bucket sxpath: '(x:ListBucketResult x:Contents x:Key *text*)))
 
 (define (put-object! bucket key object-thunk object-length object-type)
-  (perform-aws-request bucket: bucket path: key verb: "PUT" content-type: object-type body: (object-thunk)
+  (perform-aws-request bucket: bucket path: key verb: "PUT" content-type: object-type body: object-thunk
                        content-length: object-length no-xml: #t))
 
 (define (put-string! bucket key string)
-  (put-object! bucket key (lambda () string) (string-length string) "text/plain"))
+  (put-object! bucket key (lambda () (display string)) (string-length string) "text/plain"))
 
 (define (put-sexp! bucket key sexp)
   (let-values (((res request-uri response) (put-string! bucket key (->string sexp))))
     (values res request-uri response)))
 
+(define (put-file! bucket key file-path)
+  (put-object! bucket key (read-byte-file file-path) (file-size file-path) "binary/octet-stream"))
+
 (define (get-object bucket key)
   (perform-aws-request bucket: bucket path: key no-xml: #t))
 
@@ -170,6 +195,9 @@
   (let-values (((string request-uri response) (get-string bucket key)))
                (values (call-with-input-string string read) request-uri response)))
 
+(define (get-file bucket key file-path)
+  (perform-aws-request bucket: bucket path: key no-xml: #t reader-thunk: (write-byte-file file-path)))
+
 (define (delete-object! bucket key)
   (perform-aws-request bucket: bucket path: key no-xml: #t verb: "DELETE"))
 

amazon-s3.setup

@@ -11,5 +11,5 @@
   ; Files to install for your extension:
   '("amazon-s3.o" "amazon-s3.so" "amazon-s3.import.so")
   ; Assoc list with properties for your extension:
-  '((version 2)
+  '((version 7)
     (static "amazon-s3.o"))) ;; for static linking

tests/file

@@ -0,0 +1 @@
+eat good food

tests/run.scm

@@ -20,6 +20,10 @@
             (test-assert "Delete Object 2" (delete-object! *b* "string"))
             (test-assert "Put Sexp" (put-sexp! *b* "sexp" '(+ 1 2 3)))
             (test "Get Sexp" 6 (eval (get-sexp *b* "sexp")))
+	    (test-assert "Put File" (put-file! *b* "file" "test-in-file"))
+	    (test-assert "Get File" (get-file *b* "file" "test-out-file"))
+	    (test "Get/Put File 1" #t (string=? (with-input-from-file "test-in-file" (lambda () (read-string)))
+						(with-input-from-file "test-out-file" (lambda () (read-string)))))
             (test-assert "Delete Object 3" (delete-object! *b* "sexp"))
             (test-assert "Delete Bucket" (delete-bucket! *b*)))