Compare commits
7 Commits
| Author | SHA1 | Date | |
|---|---|---|---|
|
|
8fbc5a540e | ||
|
|
887319ad05 | ||
| 7b32156467 | |||
| f1f2e2a663 | |||
| 7b26d6acb2 | |||
| c78a161fa1 | |||
| 3c4ee2cf36 |
@@ -5,3 +5,6 @@
|
|||||||
(release "2")
|
(release "2")
|
||||||
(release "3")
|
(release "3")
|
||||||
(release "4")
|
(release "4")
|
||||||
|
(release "5")
|
||||||
|
(release "6")
|
||||||
|
(release "7")
|
||||||
@@ -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)
|
||||||
@@ -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,16 +183,19 @@
|
|||||||
(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)
|
||||||
(put-object! bucket key (lambda () string) (string-length string) "text/plain"))
|
(put-object! bucket key (lambda () (display string)) (string-length string) "text/plain"))
|
||||||
|
|
||||||
(define (put-sexp! bucket key sexp)
|
(define (put-sexp! bucket key sexp)
|
||||||
(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"))
|
||||||
|
|
||||||
|
|||||||
@@ -11,5 +11,5 @@
|
|||||||
; Files to install for your extension:
|
; Files to install for your extension:
|
||||||
'("amazon-s3.o" "amazon-s3.so" "amazon-s3.import.so")
|
'("amazon-s3.o" "amazon-s3.so" "amazon-s3.import.so")
|
||||||
; Assoc list with properties for your extension:
|
; Assoc list with properties for your extension:
|
||||||
'((version 2)
|
'((version 7)
|
||||||
(static "amazon-s3.o"))) ;; for static linking
|
(static "amazon-s3.o"))) ;; for static linking
|
||||||
1
tests/file
Normal file
1
tests/file
Normal file
@@ -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*)))
|
||||||
|
|
||||||
|
|||||||
Reference in New Issue
Block a user