tjhintz/chicken-scheme-amazon-s3
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Added more to the api. Weird threading errors though... Might be an issue with http-client again.

Browse Source
This commit is contained in:
Thomas Hintz
2011-05-06 02:51:11 -04:00
parent 2a40548d01
commit cce57093a1
1 changed files with 46 additions and 16 deletions
Download Patch File Download Diff File Expand all files Collapse all files

62
amazon-s3.scm
View File

@@ -8,10 +8,9 @@
*last-sig* *last-sig*
list-objects) list-objects list-buckets bucket-exists? create-bucket! delete-bucket!)
;; procs ;; procs
;bucket-exists? create-bucket delete-bucket list-buckets list-objects
;get-object put-object delete-object) ;get-object put-object delete-object)
(import scheme chicken srfi-1 extras srfi-13 data-structures ports posix) (import scheme chicken srfi-1 extras srfi-13 data-structures ports posix)
@@ -25,11 +24,13 @@
(authorization-param-subunparsers (authorization-param-subunparsers
`((aws . ,aws-param-subunparser) . ,(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 (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 (sig-date date) (date->string date "~a, ~d ~b ~Y ~T GMT"))
(define access-key (make-parameter "")) (define access-key (make-parameter "AKIAJ4BAYHGF254QF7DQ"))
(define secret-key (make-parameter "")) (define secret-key (make-parameter "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"))
(define https (make-parameter #f)) (define https (make-parameter #f))
;;; helper methods ;;; helper methods
@@ -60,40 +61,69 @@
(values hmac-sha1 can-string))) (values hmac-sha1 can-string)))
(define *last-sig* #f) (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))) (let ((n (current-date 0)))
(headers `((date #(,(intarweb-date n) ())) (headers `((date #(,(intarweb-date n) ()))
(authorization #(aws ((access-key . ,(access-key)) (authorization #(aws ((access-key . ,(access-key))
(signed-secret . (signed-secret .
,(make-aws-authorization ,(make-aws-authorization
"GET" (string-append "/" bucket "/") verb (string-append "/" (if bucket (string-append bucket "/") ""))
date: (sig-date n) date: (sig-date n)
content-type: "application/x-www-form-urlencoded"))))))))) content-type: "application/x-www-form-urlencoded")))))))))
(define (aws-request bucket path) (define (aws-request bucket path verb)
(make-request (make-request
method: 'GET method: (string->symbol verb)
uri: (uri-reference (string-append "http" (if (https) "s" "") "://" bucket ".s3.amazonaws.com")) uri: (uri-reference (string-append "http" (if (https) "s" "") "://" (if bucket (string-append bucket ".") "")
headers: (aws-headers bucket ""))) "s3.amazonaws.com"))
headers: (aws-headers bucket "" verb)))
(define (aws-xml-parser path) (define (aws-xml-parser path ns)
(lambda () (lambda ()
((sxpath path) ((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 ;(handle-exceptions
; exn ; exn
; ((condition-property-accessor 'client-error 'body) exn) ; ((condition-property-accessor 'client-error 'body) exn)
(with-input-from-request (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 ;;; api
(define (list-objects bucket) (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))
) )