From 9d843353a55c25749fe604caac972a435d7e1198 Mon Sep 17 00:00:00 2001
From: Raymond Racine <ray@corwin.bravais.org>
Date: Thu, 20 Mar 2008 19:06:56 -0400
Subject: [PATCH] Simple S3 calls working.

---
 rl3/aws/s3/s3.sls | 62 +++++++++++++++++++++++++++----------------------------
 rl3/scratch.scm   | 13 ++++++++++++
 2 files changed, 43 insertions(+), 32 deletions(-)

diff --git a/rl3/aws/s3/s3.sls b/rl3/aws/s3/s3.sls
index 2e094dd..d798bfb 100755
--- a/rl3/aws/s3/s3.sls
+++ b/rl3/aws/s3/s3.sls
@@ -21,50 +21,41 @@
 
  (export
   list-buckets         ;; (-> aws-credentials? s3-response?))
-;;   create-bucket        ;; (-> aws-credentials? s3-bucket? s3-response?))
-;;   delete-bucket        ;; (-> aws-credentials? s3-bucket? s3-response?))
-;;   put-object           ;; (-> aws-credentials? bytes? s3-resource? s3-response?))
-;;   put-file-object      ;; (-> aws-credentials? path? s3-resource? s3-response?))
-;;   head-object          ;; (-> aws-credentials? s3-resource? s3-response?))
-;;   get-object           ;; (-> aws-credentials? s3-resource? s3-response?))
-;;   delete-object        ;; (-> aws-credentials? s3-resource? s3-response?))
-;;   list-bucket-objects) ;; (-> aws-credentials? s3-bucket? s3-key? string? number? s3-response?)))    
-)
+  ;;   create-bucket        ;; (-> aws-credentials? s3-bucket? s3-response?))
+  ;;   delete-bucket        ;; (-> aws-credentials? s3-bucket? s3-response?))
+  ;;   put-object           ;; (-> aws-credentials? bytes? s3-resource? s3-response?))
+  ;;   put-file-object      ;; (-> aws-credentials? path? s3-resource? s3-response?))
+  ;;   head-object          ;; (-> aws-credentials? s3-resource? s3-response?))
+  ;;   get-object           ;; (-> aws-credentials? s3-resource? s3-response?))
+  ;;   delete-object        ;; (-> aws-credentials? s3-resource? s3-response?))
+  ;;   list-bucket-objects) ;; (-> aws-credentials? s3-bucket? s3-key? string? number? s3-response?)))    
+  )
  
  (import
   (rnrs base)
-  (rl3 aws s3 configuration)
+  (rl3 aws configuration)
+  (only (rnrs io ports)
+        close-port)
   (only (rl3 aws awscredentials)
         aws-credentials-secret-key
         aws-credentials-access-key)
   (only (rl3 web uri)
         make-uri uri->string)
+  (only (rl3 web http)
+        http-invoke http-ascii-port-from-binary-port)
+  (only (rl3 web pipes htmlprag)
+        html->sxml)
   (only (rl3 types dates)
         current-time-rfc2822)
   (only (rl3 aws awsauth)
         aws-s3-auth-str
         aws-s3-auth-mac)
   (only (rl3 aws s3 s3headers)
-        date-header))
- 
- (define s3-get    #f)
- (define s3-put    #f)
- (define s3-delete #f)
- (define s3-head   #f)
+        host-header date-header))
  
  ;; Read from configuration 
  (define s3-host (s3-configuration 'host))
-  
-  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;; Current time as a rfc2822 date string
- ;; "Sat, 8 Sep 2007 18:19:20 -0400"
- ;; unit -> string
- ;; Note: Is relative local TZ and _not_ GMT
- ;;       which is ok.
-  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (define rfc2822-date
-   (lambda ()
-     (current-time-rfc2822)))
+ (define s3host-header (host-header s3-host))
  
 ;;  (define aws-error
 ;;    (lambda (s)
@@ -89,11 +80,18 @@
  (define list-buckets
    (lambda (credentials)        
      (let ((url (build-rest-uri ""))
-           (datetime (rfc2822-date)))
-       (let ((http-headers (list (date-header datetime) 
-                                 (authorization-header credentials (aws-s3-auth-str "GET" "" "" datetime '() "/")))))
-         (values url http-headers)))))
-
+           (datetime (current-time-rfc2822)))
+       (let ((http-headers (list s3host-header
+                                 (date-header (current-time-rfc2822))
+                                 (authorization-header credentials
+                                                       (aws-s3-auth-str "GET" "" "" datetime '() "/")))))
+         (let-values (((hdrs hip) (http-invoke 'GET
+                                               (uri->string url)
+                                               http-headers)))
+           (let ((tip (http-ascii-port-from-binary-port hip)))
+             (let ((buckets (html->sxml tip)))
+               (close-port tip)
+               buckets)))))))
        
        ;;(s3-response-from-port (s3-get (list-url) http-headers)))))
  
diff --git a/rl3/scratch.scm b/rl3/scratch.scm
index 01b93c3..df261bd 100755
--- a/rl3/scratch.scm
+++ b/rl3/scratch.scm
@@ -1,4 +1,17 @@
 
+(import (rnrs base)
+        (rnrs io simple)
+        (rl3 aws s3 s3)
+        (rl3 aws awscredentials)
+        (rl3 concurrency tasks-with-io))
+
+(define creds (load-credentials "/home/ray/awsaccount.txt"))
+
+(with-tasking-io
+ (lambda ()
+   (display (list-buckets creds))))
+   
+
 ;;; S3
 
 (import (rnrs base)
-- 
2.11.4.GIT