Extend S3 object APIs for drive storage
ober
818aca8b2d2e951fe35083086003718c42616097
--- a/Makefile +++ b/Makefile @@ -7,9 +7,18 @@ ifeq ($(JH),) $(error jerbuild not found on PATH (or '$(JERBUILD) --jerboa-home' failed). Install jerbuild, or set JERBUILD=/path/to/jerbuild) endif +JERBOA_HOME ?= $(realpath $(CURDIR)/../jerboa) NATIVE_DIR := $(JH)/jerboa-native-rs/target/release LIBDIRS := --libdirs lib:$(JH)/lib JEXEC := $(JERBUILD) exec $(LIBDIRS) +ifeq ($(wildcard $(JERBOA_HOME)/lib),) +TEST_NATIVE_DIR := $(NATIVE_DIR) +TEST_RUN := $(JEXEC) +else +SCHEME ?= $(JERBOA_HOME)/.chez/bin/scheme +TEST_NATIVE_DIR := $(JERBOA_HOME)/jerboa-native-rs/target/release +TEST_RUN := $(SCHEME) -q --libdirs lib:$(JERBOA_HOME)/lib --script +endif BIN := jerboa-aws BIN_DIR := $(HOME)/.local/bin @@ -32,8 +41,10 @@ run: binary ./$(BIN) $(ARGS) test: - DYLD_FALLBACK_LIBRARY_PATH="$(NATIVE_DIR)" LD_LIBRARY_PATH="$(NATIVE_DIR):$$LD_LIBRARY_PATH" \ - $(JEXEC) test/test-all.ss + DYLD_LIBRARY_PATH="$(TEST_NATIVE_DIR):$$DYLD_LIBRARY_PATH" \ + DYLD_FALLBACK_LIBRARY_PATH="$(TEST_NATIVE_DIR)" \ + LD_LIBRARY_PATH="$(TEST_NATIVE_DIR):$$LD_LIBRARY_PATH" \ + $(TEST_RUN) test/test-all.ss install: binary mkdir -p $(BIN_DIR) --- a/lib/jerboa-aws/s3/api.sls +++ b/lib/jerboa-aws/s3/api.sls @@ -4,24 +4,38 @@ (library (jerboa-aws s3 api) (export make-s3-client S3Client + s3-build-request-target s3-canonical-query-string s3-request s3-request/xml s3-request/check - s3-get s3-put s3-delete s3-head) + s3-get s3-get-bytes s3-get-range + s3-put s3-put-bytes s3-delete s3-head + s3-create-multipart-upload + s3-upload-part + s3-complete-multipart-upload + s3-abort-multipart-upload + s3-list-parts + s3-complete-multipart-upload-body) (import (except (chezscheme) bytevector-append) (jerboa-aws creds) (jerboa-aws crypto) (jerboa-aws sigv4) (jerboa-aws time) + (jerboa-aws uri) (jerboa-aws xml) (jerboa-aws request)) ;; --- Client record --- (define-record-type s3-client - (fields endpoint access-key secret-key region token) + (fields endpoint access-key secret-key region token path-style? scheme) (protocol (lambda (new) - (lambda (endpoint access-key secret-key region token) - (new endpoint access-key secret-key region token))))) + (case-lambda + [(endpoint access-key secret-key region token) + (new endpoint access-key secret-key region token #f "https")] + [(endpoint access-key secret-key region token path-style?) + (new endpoint access-key secret-key region token path-style? "https")] + [(endpoint access-key secret-key region token path-style? scheme) + (new endpoint access-key secret-key region token path-style? scheme)])))) ;; Client factory with credential resolution (define (S3Client . args) @@ -30,7 +44,9 @@ [access-key (kw-ref args 'access-key: #f)] [secret-key (kw-ref args 'secret-key: #f)] [region (kw-ref args 'region: #f)] - [token (kw-ref args 'token: #f)]) + [token (kw-ref args 'token: #f)] + [path-style? (kw-ref args 'path-style: #f)] + [scheme (kw-ref args 'scheme: #f)]) (let-values ([(r-ak r-sk r-region r-token) (aws-resolve-credentials profile)]) (let ([ak (or access-key r-ak)] @@ -39,9 +55,13 @@ [tok (or token r-token)]) (unless ak (error 'S3Client "access key is required")) (unless sk (error 'S3Client "secret key is required")) - (make-s3-client - (or endpoint "s3.amazonaws.com") - ak sk reg tok))))) + (let-values ([(endpoint-scheme endpoint-host) + (split-endpoint-scheme + (or endpoint "s3.amazonaws.com"))]) + (make-s3-client + endpoint-host + ak sk reg tok path-style? + (or scheme endpoint-scheme "https"))))))) ;; Precomputed empty SHA256 (define empty-sha256 (sha256 #vu8())) @@ -62,15 +82,16 @@ [body (kw-ref args 'body: #f)] [content-type (kw-ref args 'content-type: #f)] [extra-headers (kw-ref args 'extra-headers: '())]) - (let* ([body-hash (if body + (let* ([target (s3-build-request-target client bucket key query)] + [host (alist-ref target 'host)] + [path (alist-ref target 'path)] + [query-string (alist-ref target 'query)] + [url (alist-ref target 'url)] + [body-hash (if body (sha256 (if (string? body) (string->utf8 body) body)) empty-sha256)] [ts (aws-timestamp)] [ds (aws-datestamp)] - [host (if bucket - (string-append bucket "." (s3-client-endpoint client)) - (s3-client-endpoint client))] - [path (if key (string-append "/" key) "/")] [headers (list (cons "Host" host) (cons "x-amz-date" ts) (cons "x-amz-content-sha256" (hex-encode body-hash)))] @@ -85,7 +106,7 @@ [headers (if (null? extra-headers) headers (append headers extra-headers))] - [auth (sigv4-sign verb path "" + [auth (sigv4-sign verb path query-string headers body-hash (s3-client-region client) "s3" @@ -95,8 +116,7 @@ [all-headers (cons (cons "Authorization" auth) headers)] ;; Convert (name . value) pairs to (name :: value) for jerboa-https [https-headers (map (lambda (h) (list (car h) ':: (cdr h))) - all-headers)] - [url (string-append "https://" host path)]) + all-headers)]) (cond [(string=? verb "GET") (http-get url 'headers: https-headers)] @@ -136,13 +156,39 @@ ;; Convenience wrappers (define (s3-get client bucket key) + (utf8->string (s3-get-bytes client bucket key))) + + (define (s3-get-bytes client bucket key) (let* ([req (s3-request/check client 'verb: "GET" 'bucket: bucket 'key: key)] - [body (request-text req)]) + [body (request-content req)]) + (request-close req) + body)) + + (define (s3-get-range client bucket key start end) + (let* ([range-value (string-append + "bytes=" + (number->string start) + "-" + (if end (number->string end) ""))] + [req (s3-request/check client + 'verb: "GET" + 'bucket: bucket + 'key: key + 'extra-headers: (list (cons "Range" range-value)))] + [body (request-content req)]) (request-close req) body)) (define (s3-put client bucket key data . args) (let ([content-type (kw-ref args 'content-type: "application/octet-stream")]) + (s3-put-bytes client bucket key + (if (bytevector? data) data (string->utf8 data)) + 'content-type: content-type))) + + (define (s3-put-bytes client bucket key data . args) + (unless (bytevector? data) + (error 's3-put-bytes "data must be a bytevector")) + (let ([content-type (kw-ref args 'content-type: "application/octet-stream")]) (let ([req (s3-request/check client 'verb: "PUT" 'bucket: bucket 'key: key 'body: data 'content-type: content-type)]) @@ -160,7 +206,198 @@ (request-close req) (and (>= status 200) (< status 300)))) + (define (s3-create-multipart-upload client bucket key . args) + (let ([content-type (kw-ref args 'content-type: #f)]) + (let ([resp + (s3-request/xml client + 'verb: "POST" + 'bucket: bucket + 'key: key + 'query: (list (cons "uploads" "")) + 'content-type: content-type)]) + (ht-ref resp 'UploadId "")))) + + (define (s3-upload-part client bucket key upload-id part-number data) + (unless (bytevector? data) + (error 's3-upload-part "data must be a bytevector")) + (let* ([req + (s3-request/check client + 'verb: "PUT" + 'bucket: bucket + 'key: key + 'query: (list (cons "partNumber" part-number) + (cons "uploadId" upload-id)) + 'body: data + 'content-type: "application/octet-stream")] + [headers (request-headers req)] + [etag-pair (assoc "etag" headers)] + [etag (and etag-pair (cdr etag-pair))]) + (request-close req) + (unless etag + (error 's3-upload-part "S3 upload-part response did not include ETag")) + (cons part-number etag))) + + (define (s3-complete-multipart-upload client bucket key upload-id parts) + (s3-request/xml client + 'verb: "POST" + 'bucket: bucket + 'key: key + 'query: (list (cons "uploadId" upload-id)) + 'body: (s3-complete-multipart-upload-body parts) + 'content-type: "application/xml")) + + (define (s3-abort-multipart-upload client bucket key upload-id) + (let ([req + (s3-request/check client + 'verb: "DELETE" + 'bucket: bucket + 'key: key + 'query: (list (cons "uploadId" upload-id)))]) + (request-close req) + (void))) + + (define (s3-list-parts client bucket key upload-id . args) + (let ([part-number-marker (kw-ref args 'part-number-marker: #f)] + [max-parts (kw-ref args 'max-parts: #f)]) + (s3-request/xml client + 'verb: "GET" + 'bucket: bucket + 'key: key + 'query: (append + (list (cons "uploadId" upload-id)) + (if part-number-marker + (list (cons "part-number-marker" part-number-marker)) + '()) + (if max-parts + (list (cons "max-parts" max-parts)) + '()))))) + ;; --- Helpers --- + (define (s3-build-request-target client bucket key query) + (let* ([scheme (s3-client-scheme client)] + [endpoint (s3-client-endpoint client)] + [encoded-key (if key (s3-encode-key-path key) "")] + [query-string (s3-canonical-query-string query)] + [path-style? (and bucket (s3-client-path-style? client))] + [host (cond + [path-style? endpoint] + [bucket (string-append bucket "." endpoint)] + [else endpoint])] + [path (cond + [path-style? + (string-append "/" bucket + (if (and key (> (string-length encoded-key) 0)) + (string-append "/" encoded-key) + ""))] + [key (string-append "/" encoded-key)] + [else "/"])] + [url (string-append scheme "://" host path + (if (> (string-length query-string) 0) + (string-append "?" query-string) + ""))]) + (list (cons 'scheme scheme) + (cons 'host host) + (cons 'path path) + (cons 'query query-string) + (cons 'url url)))) + + (define (s3-canonical-query-string query) + (if (or (not query) (null? query)) + "" + (string-join + (map (lambda (p) + (string-append (car p) "=" (cdr p))) + (list-sort + (lambda (a b) + (or (string<? (car a) (car b)) + (and (string=? (car a) (car b)) + (string<? (cdr a) (cdr b))))) + (map (lambda (p) + (cons (uri-encode (query-part->string (car p))) + (uri-encode (query-part->string (cdr p))))) + query))) + "&"))) + + (define (s3-complete-multipart-upload-body parts) + (string-append + "<CompleteMultipartUpload>" + (apply string-append + (map (lambda (part) + (string-append + "<Part><PartNumber>" + (number->string (multipart-part-number part)) + "</PartNumber><ETag>" + (xml-escape (multipart-part-etag part)) + "</ETag></Part>")) + parts)) + "</CompleteMultipartUpload>")) + + (define (multipart-part-number part) + (cond + [(and (pair? part) (number? (car part))) (car part)] + [(hashtable? part) + (or (hashtable-ref part 'PartNumber #f) + (hashtable-ref part "PartNumber" #f) + (error 'multipart-part-number "part is missing PartNumber" part))] + [else (error 'multipart-part-number "unsupported multipart part" part)])) + + (define (multipart-part-etag part) + (cond + [(and (pair? part) (string? (cdr part))) (cdr part)] + [(hashtable? part) + (or (hashtable-ref part 'ETag #f) + (hashtable-ref part "ETag" #f) + (error 'multipart-part-etag "part is missing ETag" part))] + [else (error 'multipart-part-etag "unsupported multipart part" part)])) + + (define (xml-escape value) + (let ([s (if (string? value) value (format "~a" value))] + [out (open-output-string)]) + (string-for-each + (lambda (c) + (cond + [(char=? c #\&) (put-string out "&")] + [(char=? c #\<) (put-string out "<")] + [(char=? c #\>) (put-string out ">")] + [else (write-char c out)])) + s) + (get-output-string out))) + + (define (s3-encode-key-path key) + (let ([out (open-output-string)]) + (string-for-each + (lambda (c) + (if (char=? c #\/) + (write-char c out) + (put-string out (uri-encode (string c))))) + key) + (get-output-string out))) + + (define (query-part->string value) + (cond + [(string? value) value] + [(symbol? value) (symbol->string value)] + [(number? value) (number->string value)] + [(boolean? value) (if value "true" "false")] + [(not value) ""] + [else (format "~a" value)])) + + (define (split-endpoint-scheme endpoint) + (cond + [(string-prefix? "https://" endpoint) + (values "https" (substring endpoint 8 (string-length endpoint)))] + [(string-prefix? "http://" endpoint) + (values "http" (substring endpoint 7 (string-length endpoint)))] + [else (values #f endpoint)])) + + (define (string-prefix? prefix str) + (and (>= (string-length str) (string-length prefix)) + (string=? (substring str 0 (string-length prefix)) prefix))) + + (define (alist-ref alist key) + (let ([p (assoc key alist)]) + (if p (cdr p) #f))) + (define (s3-error-raise who status body) (let ([parsed (guard (e [#t #f]) (aws-response->hash body))]) @@ -183,4 +420,10 @@ (cadr rest)] [else (loop (cdr rest))]))) + (define (string-join strs sep) + (if (null? strs) "" + (let loop ([rest (cdr strs)] [out (car strs)]) + (if (null? rest) out + (loop (cdr rest) (string-append out sep (car rest))))))) + ) ;; end library --- a/lib/jerboa-aws/s3/objects.sls +++ b/lib/jerboa-aws/s3/objects.sls @@ -2,20 +2,25 @@ ;;; (jerboa-aws s3 objects) -- S3 Object operations (library (jerboa-aws s3 objects) - (export get-object head-object put-object delete-object - list-objects-v2 copy-object delete-objects) + (export get-object get-object-bytes get-object-range + head-object put-object put-object-bytes delete-object + object-exists? + list-objects-v2 list-objects-v2/all + create-multipart-upload upload-part complete-multipart-upload + abort-multipart-upload list-parts + copy-object delete-objects) (import (chezscheme) (jerboa-aws request) (jerboa-aws s3 api)) (define (get-object client bucket-name key) - (let* ([req (s3-request/check client - 'verb: "GET" - 'bucket: bucket-name - 'key: key)] - [data (request-text req)]) - (request-close req) - data)) + (s3-get client bucket-name key)) + + (define (get-object-bytes client bucket-name key) + (s3-get-bytes client bucket-name key)) + + (define (get-object-range client bucket-name key start end) + (s3-get-range client bucket-name key start end)) (define (head-object client bucket-name key) (let* ([req (s3-request/check client @@ -28,14 +33,11 @@ (define (put-object client bucket-name key data . args) (let ([content-type (kw-ref args 'content-type: "application/octet-stream")]) - (let ([req (s3-request/check client - 'verb: "PUT" - 'bucket: bucket-name - 'key: key - 'body: data - 'content-type: content-type)]) - (request-close req) - (void)))) + (s3-put client bucket-name key data 'content-type: content-type))) + + (define (put-object-bytes client bucket-name key data . args) + (let ([content-type (kw-ref args 'content-type: "application/octet-stream")]) + (s3-put-bytes client bucket-name key data 'content-type: content-type))) (define (delete-object client bucket-name key) (let ([req (s3-request/check client @@ -45,6 +47,9 @@ (request-close req) (void))) + (define (object-exists? client bucket-name key) + (s3-head client bucket-name key)) + (define (list-objects-v2 client bucket-name . args) (let ([prefix (kw-ref args 'prefix: #f)] [delimiter (kw-ref args 'delimiter: #f)] @@ -72,6 +77,48 @@ 'bucket: bucket-name 'query: query)))) + (define (list-objects-v2/all client bucket-name . args) + (let ([prefix (kw-ref args 'prefix: #f)] + [delimiter (kw-ref args 'delimiter: #f)] + [max-keys (kw-ref args 'max-keys: #f)] + [start-after (kw-ref args 'start-after: #f)]) + (let loop ([token #f] [out '()]) + (let* ([page (list-objects-v2 client bucket-name + 'prefix: prefix + 'delimiter: delimiter + 'max-keys: max-keys + 'continuation-token: token + 'start-after: start-after)] + [contents (xml-value-list (ht-ref page 'Contents #f))] + [next-token (ht-ref page 'NextContinuationToken #f)] + [truncated? (truthy? (ht-ref page 'IsTruncated #f))] + [out (append out contents)]) + (if (and truncated? next-token) + (loop next-token out) + out))))) + + (define (create-multipart-upload client bucket-name key . args) + (let ([content-type (kw-ref args 'content-type: #f)]) + (s3-create-multipart-upload + client bucket-name key 'content-type: content-type))) + + (define (upload-part client bucket-name key upload-id part-number data) + (s3-upload-part client bucket-name key upload-id part-number data)) + + (define (complete-multipart-upload client bucket-name key upload-id parts) + (s3-complete-multipart-upload client bucket-name key upload-id parts)) + + (define (abort-multipart-upload client bucket-name key upload-id) + (s3-abort-multipart-upload client bucket-name key upload-id)) + + (define (list-parts client bucket-name key upload-id . args) + (let ([part-number-marker (kw-ref args 'part-number-marker: #f)] + [max-parts (kw-ref args 'max-parts: #f)]) + (s3-list-parts + client bucket-name key upload-id + 'part-number-marker: part-number-marker + 'max-parts: max-parts))) + (define (copy-object client bucket-name key source) (let ([req (s3-request/check client 'verb: "PUT" @@ -102,6 +149,35 @@ (void)))) ;; --- Helpers --- + (define (ht-ref ht key default) + (guard (e [#t default]) + (let ([v (hashtable-ref ht key #f)]) + (or v default)))) + + (define (truthy? value) + (cond + [(eq? value #t) #t] + [(string? value) + (or (string-ci=? value "true") + (string=? value "1"))] + [else #f])) + + (define (xml-value-list value) + (cond + [(not value) '()] + [(list? value) (flatten-xml-list value)] + [else (list value)])) + + (define (flatten-xml-list value) + (cond + [(null? value) '()] + [(and (pair? value) (list? (car value))) + (append (flatten-xml-list (car value)) + (flatten-xml-list (cdr value)))] + [(pair? value) + (cons (car value) (flatten-xml-list (cdr value)))] + [else (list value)])) + (define (kw-ref args key default) (let loop ([rest args]) (cond new file mode 100644 --- /dev/null +++ b/test/test-all.ss @@ -0,0 +1,114 @@ +#!chezscheme +(import (chezscheme) + (jerboa-aws s3 api) + (jerboa-aws s3 objects)) + +(define failures 0) + +(define (note line) + (display line) + (newline)) + +(define (check name actual expected) + (if (equal? actual expected) + (note (string-append "ok - " name)) + (begin + (set! failures (+ failures 1)) + (note (string-append "not ok - " name)) + (display " expected: ") + (write expected) + (newline) + (display " actual: ") + (write actual) + (newline)))) + +(define (alist-ref alist key) + (let ([p (assoc key alist)]) + (and p (cdr p)))) + +(define path-client + (S3Client + 'endpoint: "http://localhost:9000" + 'access-key: "ak" + 'secret-key: "sk" + 'region: "us-test-1" + 'path-style: #t)) + +(define virtual-client + (S3Client + 'endpoint: "s3.amazonaws.com" + 'access-key: "ak" + 'secret-key: "sk" + 'region: "us-east-1")) + +(define legacy-client + (make-s3-client "s3.example.test" "ak" "sk" "us-west-2" #f)) + +(check + "canonical query sorts and encodes" + (s3-canonical-query-string + (list (cons "z" "last") + (cons "a b" "x/y") + (cons "a" ""))) + "a=&a%20b=x%2Fy&z=last") + +(let ([target (s3-build-request-target + path-client + "bucket" + "dir/a b.bin" + (list (cons "prefix" "a b") + (cons "list-type" 2) + (cons "continuation-token" "z/y")))]) + (check "path-style host" (alist-ref target 'host) "localhost:9000") + (check "path-style path" (alist-ref target 'path) "/bucket/dir/a%20b.bin") + (check + "path-style query" + (alist-ref target 'query) + "continuation-token=z%2Fy&list-type=2&prefix=a%20b") + (check + "path-style url" + (alist-ref target 'url) + "http://localhost:9000/bucket/dir/a%20b.bin?continuation-token=z%2Fy&list-type=2&prefix=a%20b")) + +(let ([target (s3-build-request-target + virtual-client + "bucket" + "folder/name with space" + #f)]) + (check "virtual host" (alist-ref target 'host) "bucket.s3.amazonaws.com") + (check "virtual path" (alist-ref target 'path) "/folder/name%20with%20space") + (check + "virtual url" + (alist-ref target 'url) + "https://bucket.s3.amazonaws.com/folder/name%20with%20space")) + +(let ([target (s3-build-request-target + legacy-client + "bucket" + "object" + #f)]) + (check "legacy constructor host" (alist-ref target 'host) "bucket.s3.example.test") + (check "legacy constructor scheme" (alist-ref target 'scheme) "https")) + +(check "byte get export" (procedure? get-object-bytes) #t) +(check "range get export" (procedure? get-object-range) #t) +(check "byte put export" (procedure? put-object-bytes) #t) +(check "paginated list export" (procedure? list-objects-v2/all) #t) +(check "multipart create export" (procedure? create-multipart-upload) #t) +(check "multipart upload part export" (procedure? upload-part) #t) +(check "multipart complete export" (procedure? complete-multipart-upload) #t) +(check + "multipart complete XML escapes etags" + (s3-complete-multipart-upload-body + (list (cons 1 "\"etag&1\"") + (cons 2 "\"etag<2>\""))) + "<CompleteMultipartUpload><Part><PartNumber>1</PartNumber><ETag>\"etag&1\"</ETag></Part><Part><PartNumber>2</PartNumber><ETag>\"etag<2>\"</ETag></Part></CompleteMultipartUpload>") + +(if (= failures 0) + (begin + (note "all tests passed") + (exit 0)) + (begin + (display failures) + (note " tests failed") + (exit 1)))