readme

Add deprecated message to with-bucket.

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.

README.md

@@ -0,0 +1,8 @@
+chicken-scheme-amazon-s3
+========================
+
+Amazon S3 access from Chicken Scheme.
+
+This project has been moved to
+https://github.com/sethalves/chicken-scheme-amazon-s3.
+Use it instead for submitting patches and pull requests instead.

amazon-s3.meta

@@ -0,0 +1,15 @@
+; author: Thomas Hintz
+; email: t@thintz.com
+; license: bsd
+
+(
+(license "BSD")
+
+(category web)
+
+(needs base64 sha1 http-client uri-common intarweb srfi-19 hmac ssax sxpath)
+
+(test-depends test srfi-1)
+
+(author "Thomas Hintz")
+(synopsis "Provides an interface to the Amazon S3 service."))

amazon-s3.release-info

@@ -0,0 +1,10 @@
+(repo git "git://github.com/ThomasHintz/chicken-scheme-{egg-name}.git")   ; optional
+
+(uri targz "https://github.com/ThomasHintz/chicken-scheme-{egg-name}/tarball/{egg-release}")
+(release "1")
+(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)
@@ -103,31 +103,65 @@
                              (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))))
 
+(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
 
+; broken and deprecated
+; next version will have parameterized keywords so this
+; won't be necessary
 (define-syntax with-bucket
   (syntax-rules ()
     ((with-bucket bucket (func p1 ...))
      (func bucket p1 ...))
     ((with-bucket bucket exp body ...)
-     (begin (with-bucket bucket exp)
+     (begin (print "I am deprecated.")
+            (with-bucket bucket exp)
             (with-bucket bucket body ...)))))
 
 (define (list-buckets)
@@ -150,16 +184,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 +207,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

@@ -0,0 +1,15 @@
+; author: Thomas Hintz
+; email: t@thintz.com
+; license: bsd
+
+(compile -s -O2 -d1 amazon-s3.scm -j amazon-s3)
+(compile -s amazon-s3.import.scm -O2 -d0)
+(compile -c -O2 -d1 amazon-s3.scm -unit amazon-s3 -j amazon-s3)
+
+(install-extension
+  'amazon-s3
+  ; Files to install for your extension:
+  '("amazon-s3.o" "amazon-s3.so" "amazon-s3.import.so")
+  ; Assoc list with properties for your extension:
+  '((version 7)
+    (static "amazon-s3.o"))) ;; for static linking

tests/file

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

tests/run.scm

@@ -2,10 +2,7 @@
 ; email: t@thintz.com
 ; license: bsd
 
-(load "amazon-s3.scm")
+(use test srfi-1 amazon-s3)
-
-(use test srfi-1)
-(use amazon-s3)
 
 (define *b* "chicken-scheme-test-bucket")
 
@@ -23,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*)))