diff --git a/amazon-s3.scm b/amazon-s3.scm index e8b3e62..931a8ff 100644 --- a/amazon-s3.scm +++ b/amazon-s3.scm @@ -8,10 +8,10 @@ *last-sig* - list-objects list-buckets bucket-exists? create-bucket! delete-bucket!) + list-objects list-buckets bucket-exists? create-bucket! delete-bucket! get-object) ;; procs - ;get-object put-object delete-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 sxpath) @@ -35,6 +35,12 @@ ;;; helper methods +(define (assert-404 exn) + (if (string=? ((condition-property-accessor 'exn 'message) exn) + "Client error: 404 Not Found") + #f + (abort exn))) + (define (make-aws-authorization verb resource #!key (date #f) (amz-headers '()) (content-md5 #f) (content-type #f)) (let* ((can-amz-headers (sort (map (lambda (header) `(,(string-downcase (car header)) . ,(cdr header))) @@ -69,61 +75,70 @@ (authorization #(aws ((access-key . ,(access-key)) (signed-secret . ,(make-aws-authorization - verb (string-append "/" (if bucket (string-append bucket "/") "")) + verb + (string-append "/" + (if bucket (string-append bucket "/") "") + (if path path "")) date: (sig-date n) content-type: "application/x-www-form-urlencoded"))))))))) -(define (aws-request bucket path verb) +(define (aws-request bucket path verb #!key no-auth) (make-request 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))) + "s3.amazonaws.com" (if path (string-append "/" path) ""))) + headers: (if no-auth (headers '()) (aws-headers bucket path verb)))) (define (aws-xml-parser path ns) (lambda () ((sxpath path) (ssax:xml->sxml (current-input-port) ns)))) -(define (perform-aws-request bucket path sxpath-path verb #!key +(define (perform-aws-request bucket path #!key + (content #f) + (sxpath '()) + (verb (if content "PUT" "GET")) (ns '((x . "http://s3.amazonaws.com/doc/2006-03-01/"))) - (no-xml #f)) + (no-xml #f) + (params '()) + (no-auth #f)) ;(handle-exceptions ; exn ; ((condition-property-accessor 'client-error 'body) exn) (with-input-from-request - (aws-request bucket path verb) - '() + (aws-request bucket path verb no-auth: no-auth) + params (if no-xml read-string - (aws-xml-parser sxpath-path ns)))) + (aws-xml-parser sxpath ns)))) ;;; api (define (list-objects bucket) - (perform-aws-request bucket "" '(x:ListBucketResult x:Contents x:Key *text*) "GET")) + (perform-aws-request bucket #f sxpath: '(x:ListBucketResult x:Contents x:Key *text*))) (define (list-buckets) - (perform-aws-request #f "" '(x:ListAllMyBucketsResult x:Buckets x:Bucket x:Name *text*) "GET")) + (perform-aws-request #f #f sxpath: '(x:ListAllMyBucketsResult x:Buckets x:Bucket x:Name *text*))) -; 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) + (assert-404 exn) + (perform-aws-request #f bucket verb: "HEAD" no-xml: #t params: '((max-keys . "0"))) #t)) (define (create-bucket! bucket) - (perform-aws-request bucket "" '() "PUT" no-xml: #t)) - + (perform-aws-request bucket #f verb: "PUT" no-xml: #t)) (define (delete-bucket! bucket) - (perform-aws-request bucket "" '() "DELETE" no-xml: #t)) + (perform-aws-request bucket #f verb: "DELETE" no-xml: #t)) + +(define (set-object! bucket key object) #f) + ;(perform-aws-request bucket key '() + +(define (get-object bucket key) + (perform-aws-request bucket key no-xml: #t)) + +(define (delete-object bucket key) #f) ) \ No newline at end of file diff --git a/tests/run.scm b/tests/run.scm new file mode 100644 index 0000000..6aa6fb6 --- /dev/null +++ b/tests/run.scm @@ -0,0 +1,20 @@ +; author: Thomas Hintz +; email: t@thintz.com +; license: bsd + +(load "amazon-s3.scm") + +(use test srfi-1) +(use amazon-s3) + +(define *b* "chicken-scheme-test-bucket") + +(test-group "Amazon S3" + (test "Bucket Exists 1" #f (bucket-exists? *b*)) + (test-assert "Create Bucket" (create-bucket! *b*)) + (test "Bucket Exists 2" #t (bucket-exists? *b*)) + (test-assert "List Buckets" (list-buckets)) ; should test this more specifically... + (test "List Bucket Objects" '() (list-objects *b*)) + (test-assert "Delete Bucket" (delete-bucket! *b*))) + +(test-exit) \ No newline at end of file