Fix put-string! and put-sexp!.

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

amazon-s3.release-info

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

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))))
-                                      ""
-                                      can-amz-headers))
+					  (string-append o (sprintf "~a:~a~%" (car e) (cdr e))))
+					""
+					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,11 +103,12 @@
                              (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
@@ -117,9 +118,41 @@
    (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))))
 
+(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 (write-byte-file path . port)
+  (lambda ()
+    (let ((file (open-output-file path)))
+      (letrec ((read-next
+		(lambda ()
+		  (let ((b (if (> (length port) 0)
+			       (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-syntax with-bucket
@@ -150,16 +183,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 +206,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 5)
+  '((version 6)
     (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*)))