added get/put file

test-github-pull-request
t@thintz.com 13 years ago
parent 3c4ee2cf36
commit c78a161fa1

@ -11,7 +11,7 @@
;; procs ;; procs
list-objects list-buckets bucket-exists? create-bucket! delete-bucket! get-object put-object! delete-object! list-objects list-buckets bucket-exists? create-bucket! delete-bucket! get-object put-object! delete-object!
put-string! put-sexp! get-string get-sexp put-string! put-sexp! put-file! get-string get-sexp get-file
;; macros ;; macros
with-bucket) with-bucket)
@ -32,8 +32,8 @@
(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
@ -103,11 +103,12 @@
(bucket #f) (bucket #f)
(path #f) (path #f)
(sxpath '()) (sxpath '())
(body '()) (body "")
(verb "GET") (verb "GET")
(ns '((x . "http://s3.amazonaws.com/doc/2006-03-01/"))) (ns '((x . "http://s3.amazonaws.com/doc/2006-03-01/")))
(no-xml #f) (no-xml #f)
(no-auth #f) (no-auth #f)
(reader-thunk read-string)
(content-type "application/x-www-form-urlencoded") (content-type "application/x-www-form-urlencoded")
(content-length 0)) (content-length 0))
;(handle-exceptions ;(handle-exceptions
@ -117,9 +118,41 @@
(aws-request bucket path verb no-auth: no-auth content-type: content-type content-length: content-length) (aws-request bucket path verb no-auth: no-auth content-type: content-type content-length: content-length)
body body
(if no-xml (if no-xml
read-string reader-thunk
(aws-xml-parser sxpath ns)))) (aws-xml-parser sxpath ns))))
(define (read-byte-file path . port)
(lambda ()
(let ((file (open-input-file path)))
(letrec ((read-next
(lambda ()
(let ((b (read-byte file)))
(if (eof-object? b)
#t
(begin
(if (> (length port) 0)
(write-byte b (car port))
(write-byte b))
(read-next)))))))
(read-next))
(close-input-port file))))
(define (write-byte-file path . port)
(lambda ()
(let ((file (open-output-file path)))
(letrec ((read-next
(lambda ()
(let ((b (if (> (length port) 0)
(read-byte (car port))
(read-byte))))
(if (eof-object? b)
#t
(begin
(write-byte b file)
(read-next)))))))
(read-next))
(close-output-port file))))
;;; api ;;; api
(define-syntax with-bucket (define-syntax with-bucket
@ -150,7 +183,7 @@
(perform-aws-request bucket: bucket sxpath: '(x:ListBucketResult x:Contents x:Key *text*))) (perform-aws-request bucket: bucket sxpath: '(x:ListBucketResult x:Contents x:Key *text*)))
(define (put-object! bucket key object-thunk object-length object-type) (define (put-object! bucket key object-thunk object-length object-type)
(perform-aws-request bucket: bucket path: key verb: "PUT" content-type: object-type body: (object-thunk) (perform-aws-request bucket: bucket path: key verb: "PUT" content-type: object-type body: object-thunk
content-length: object-length no-xml: #t)) content-length: object-length no-xml: #t))
(define (put-string! bucket key string) (define (put-string! bucket key string)
@ -160,6 +193,9 @@
(let-values (((res request-uri response) (put-string! bucket key (->string sexp)))) (let-values (((res request-uri response) (put-string! bucket key (->string sexp))))
(values res request-uri response))) (values res request-uri response)))
(define (put-file! bucket key file-path)
(put-object! bucket key (read-byte-file file-path) (file-size file-path) "binary/octet-stream"))
(define (get-object bucket key) (define (get-object bucket key)
(perform-aws-request bucket: bucket path: key no-xml: #t)) (perform-aws-request bucket: bucket path: key no-xml: #t))
@ -170,6 +206,9 @@
(let-values (((string request-uri response) (get-string bucket key))) (let-values (((string request-uri response) (get-string bucket key)))
(values (call-with-input-string string read) request-uri response))) (values (call-with-input-string string read) request-uri response)))
(define (get-file bucket key file-path)
(perform-aws-request bucket: bucket path: key no-xml: #t reader-thunk: (write-byte-file file-path)))
(define (delete-object! bucket key) (define (delete-object! bucket key)
(perform-aws-request bucket: bucket path: key no-xml: #t verb: "DELETE")) (perform-aws-request bucket: bucket path: key no-xml: #t verb: "DELETE"))

@ -0,0 +1 @@
eat good food

@ -20,6 +20,10 @@
(test-assert "Delete Object 2" (delete-object! *b* "string")) (test-assert "Delete Object 2" (delete-object! *b* "string"))
(test-assert "Put Sexp" (put-sexp! *b* "sexp" '(+ 1 2 3))) (test-assert "Put Sexp" (put-sexp! *b* "sexp" '(+ 1 2 3)))
(test "Get Sexp" 6 (eval (get-sexp *b* "sexp"))) (test "Get Sexp" 6 (eval (get-sexp *b* "sexp")))
(test-assert "Put File" (put-file! *b* "file" "test-in-file"))
(test-assert "Get File" (get-file *b* "file" "test-out-file"))
(test "Get/Put File 1" #t (string=? (with-input-from-file "test-in-file" (lambda () (read-string)))
(with-input-from-file "test-out-file" (lambda () (read-string)))))
(test-assert "Delete Object 3" (delete-object! *b* "sexp")) (test-assert "Delete Object 3" (delete-object! *b* "sexp"))
(test-assert "Delete Bucket" (delete-bucket! *b*))) (test-assert "Delete Bucket" (delete-bucket! *b*)))

Loading…
Cancel
Save