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

Finally got every part working! Added SSAX and SXPath stuff.

Browse Source
This commit is contained in:
Thomas Hintz
2011-05-06 01:24:21 -04:00
parent ee03424410
commit 68ca72bd4f
1 changed files with 26 additions and 14 deletions
Download Patch File Download Diff File Expand all files Collapse all files

32
amazon-s3.scm
View File

@@ -15,13 +15,20 @@
;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)
(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 ; needed to make intarweb work with Amazon's screwy authorization header
(header-unparsers (define (aws-param-subunparser params)
(alist-update! 'authorization (sprintf "~A:~A" (alist-ref 'access-key params)
(lambda (v) (list (vector-ref (first v) 0))) (alist-ref 'signed-secret params)))
(header-unparsers)))
(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 (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"))
@@ -67,13 +74,18 @@
uri: (uri-reference (string-append "http" (if (https) "s" "") "://" bucket ".s3.amazonaws.com")) uri: (uri-reference (string-append "http" (if (https) "s" "") "://" bucket ".s3.amazonaws.com"))
headers: (let ((n (current-date 0))) headers: (let ((n (current-date 0)))
(headers `((date #(,(intarweb-date n) ())) (headers `((date #(,(intarweb-date n) ()))
(authorization ,(string-append "AWS " (access-key) ":" ; (authorization ,(string-append "AWS " (access-key) ":"
(make-aws-authorization (authorization #(aws ((access-key . ,(access-key))
(signed-secret .
,(make-aws-authorization
"GET" (string-append "/" bucket "/") "GET" (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")))))))))
'() '()
(lambda () (ssax:xml->sxml (current-input-port) '())))) (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 ; (make-request method: 'GET
; uri: (uri-reference "http://s3.amazonaws.com/test-bucket-keep-the-records") ; 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")) ())) ; 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))) ; read-string)))
) )