From cce57093a1c1d2d8a4b8b9d98c53a6fbb8cf3b14 Mon Sep 17 00:00:00 2001
From: Thomas Hintz <t@thintz.com>
Date: Fri, 6 May 2011 02:51:11 -0400
Subject: [PATCH] Added more to the api. Weird threading errors though... Might
 be an issue with http-client again.

---
 amazon-s3.scm | 62 ++++++++++++++++++++++++++++++++++++++-------------
 1 file changed, 46 insertions(+), 16 deletions(-)

diff --git a/amazon-s3.scm b/amazon-s3.scm
index 0649b9c..9d21228 100644
--- a/amazon-s3.scm
+++ b/amazon-s3.scm
@@ -8,10 +8,9 @@
 
               *last-sig*
 
-   list-objects)
+   list-objects list-buckets bucket-exists? create-bucket! delete-bucket!)
               
    ;; procs
-   ;bucket-exists? create-bucket delete-bucket list-buckets list-objects
    ;get-object put-object delete-object)
 
 (import scheme chicken srfi-1 extras srfi-13 data-structures ports posix)
@@ -25,11 +24,13 @@
 (authorization-param-subunparsers
  `((aws . ,aws-param-subunparser) . ,(authorization-param-subunparsers)))
 
+;;; params
+
 (define (intarweb-date date) (string->time (date->string date "~a ~b ~d ~T ~Y GMT")))
 (define (sig-date date) (date->string date "~a, ~d ~b ~Y ~T GMT"))
 
-(define access-key (make-parameter ""))
-(define secret-key (make-parameter ""))
+(define access-key (make-parameter "AKIAJ4BAYHGF254QF7DQ"))
+(define secret-key (make-parameter "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"))
 (define https (make-parameter #f))
 
 ;;; helper methods
@@ -60,40 +61,69 @@
     (values hmac-sha1 can-string)))
 
 (define *last-sig* #f)
+(define amazon-ns (make-parameter '(x . "http://s3.amazonaws.com/doc/2006-03-01/")))
 
-(define (aws-headers bucket path)
+(define (aws-headers bucket path verb)
   (let ((n (current-date 0)))
     (headers `((date #(,(intarweb-date n) ()))
                (authorization #(aws ((access-key . ,(access-key))
                                      (signed-secret .
                                                     ,(make-aws-authorization
-                                                      "GET" (string-append "/" bucket "/")
+                                                      verb (string-append "/" (if bucket (string-append bucket "/") ""))
                                                       date: (sig-date n)
                                                       content-type: "application/x-www-form-urlencoded")))))))))
 
-(define (aws-request bucket path)
+(define (aws-request bucket path verb)
   (make-request
-   method: 'GET
-   uri: (uri-reference (string-append "http" (if (https) "s" "") "://" bucket ".s3.amazonaws.com"))
-   headers: (aws-headers bucket "")))
+   method: (string->symbol verb)
+   uri: (uri-reference (string-append "http" (if (https) "s" "") "://" (if bucket (string-append bucket ".") "")
+                                      "s3.amazonaws.com"))
+   headers: (aws-headers bucket "" verb)))
 
-(define (aws-xml-parser path)
+(define (aws-xml-parser path ns)
   (lambda () 
      ((sxpath path)
-      (ssax:xml->sxml (current-input-port) '((x . "http://s3.amazonaws.com/doc/2006-03-01/"))))))
+      (ssax:xml->sxml (current-input-port) ns))))
 
-(define (perform-aws-request bucket path sxpath-path)
+(define (perform-aws-request bucket path sxpath-path verb #!key
+                             (ns '((x . "http://s3.amazonaws.com/doc/2006-03-01/")))
+                             (no-xml #f))
   ;(handle-exceptions
   ; exn
   ; ((condition-property-accessor 'client-error 'body) exn)
   (with-input-from-request
-   (aws-request bucket path)
+   (aws-request bucket path verb)
    '()
-   (aws-xml-parser sxpath-path)))
+   (if no-xml
+       read-string
+       (aws-xml-parser sxpath-path ns))))
 
 ;;; api
 
 (define (list-objects bucket)
-  (perform-aws-request bucket "" '(x:ListBucketResult x:Contents x:Key *text*)))
+  (perform-aws-request bucket "" '(x:ListBucketResult x:Contents x:Key *text*) "GET"))
+
+(define (list-buckets)
+  (perform-aws-request #f "" '(x:ListAllMyBucketsResult x:Buckets x:Bucket x:Name *text*) "GET"))
+
+; probably should use something faster than list-objects for the test...
+(define (bucket-exists? bucket)
+  (handle-exceptions
+   exn
+   (if (string=? (call-with-input-string ((condition-property-accessor 'client-error 'body) exn)
+                               (lambda (p)
+                                 (first ((sxpath '(Error Code *text*)) (ssax:xml->sxml p '())))))
+                 "NoSuchBucket")
+       #f
+       (abort exn))
+   (list-objects bucket)
+   #t))
+
+(define (create-bucket! bucket)
+  (perform-aws-request bucket "" '() "PUT" no-xml: #t))
+
+
+(define (delete-bucket! bucket)
+  (perform-aws-request bucket "" '() "DELETE" no-xml: #t))
 
 )
\ No newline at end of file