diff --git a/amazon-s3.scm b/amazon-s3.scm index ecc5b1a..1f1eeed 100644 --- a/amazon-s3.scm +++ b/amazon-s3.scm @@ -15,13 +15,20 @@ ;get-object put-object delete-object) (import scheme chicken srfi-1 extras srfi-13 data-structures ports posix) -(use base64 sha1 http-client uri-common intarweb srfi-19 hmac ssax) +(use base64 sha1 http-client uri-common intarweb srfi-19 hmac ssax sxpath) + +;(header-unparsers +; (alist-update! 'authorization +; (lambda (v) (list (vector-ref (first v) 0))) +; (header-unparsers))) ; needed to make intarweb work with Amazon's screwy authorization header -(header-unparsers - (alist-update! 'authorization - (lambda (v) (list (vector-ref (first v) 0))) - (header-unparsers))) +(define (aws-param-subunparser params) + (sprintf "~A:~A" (alist-ref 'access-key params) + (alist-ref 'signed-secret params))) + +(authorization-param-subunparsers + `((aws . ,aws-param-subunparser) . ,(authorization-param-subunparsers))) (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")) @@ -58,22 +65,27 @@ (define *last-sig* #f) (define (list-objects bucket) -; (handle-exceptions -; exn -; ((condition-property-accessor 'client-error 'body) exn) + ;(handle-exceptions + ; exn + ; ((condition-property-accessor 'client-error 'body) exn) (with-input-from-request (make-request method: 'GET uri: (uri-reference (string-append "http" (if (https) "s" "") "://" bucket ".s3.amazonaws.com")) headers: (let ((n (current-date 0))) (headers `((date #(,(intarweb-date n) ())) - (authorization ,(string-append "AWS " (access-key) ":" - (make-aws-authorization +; (authorization ,(string-append "AWS " (access-key) ":" + (authorization #(aws ((access-key . ,(access-key)) + (signed-secret . + ,(make-aws-authorization "GET" (string-append "/" bucket "/") date: (sig-date n) - content-type: "application/x-www-form-urlencoded"))))))) - '() - (lambda () (ssax:xml->sxml (current-input-port) '())))) + content-type: "application/x-www-form-urlencoded"))))))))) + '() + (lambda () + ((sxpath '(x:ListBucketResult x:Contents x:Key *text*)) + (ssax:xml->sxml (current-input-port) '((x . "http://s3.amazonaws.com/doc/2006-03-01/"))))))) + ;read-string))) @@ -95,7 +107,7 @@ ; (make-request method: 'GET ; uri: (uri-reference "http://s3.amazonaws.com/test-bucket-keep-the-records") ; headers: (headers `((date #(,(string->time (date->string *date-as-date* "~a ~b ~d ~T ~Y GMT")) ())) -; (authorization ,(string-append "" (sig)))))) +; (authorization ,(string-append ":" (sig)))))) ; '() ; read-string))) )