diff --git a/src/std/net/s3/api.ss b/src/std/net/s3/api.ss index bf8ffd330c..fdd7452368 100644 --- a/src/std/net/s3/api.ss +++ b/src/std/net/s3/api.ss @@ -2,6 +2,7 @@ ;;; (C) vyzo ;;; AWS S3 client (import "sigv4" + "interface" :std/net/request :std/misc/func :std/contract @@ -12,11 +13,23 @@ :std/error :std/sugar :std/srfi/19) -(export (struct-out s3-client bucket) S3ClientError) +(export make-s3-client S3ClientError) + + +(def (make-s3-client + (endpoint "s3.amazonaws.com") + (access-key (getenv "AWS_ACCESS_KEY_ID" #f)) + (secret-key (getenv "AWS_SECRET_ACCESS_KEY" #f)) + (region (getenv "AWS_DEFAULT_REGION" "us-east-1")) + (cond + ((not access-key) + (raise-s3-error make-s3-client "Must provide access key" "access-key")) + ((not secret-key) + (raise-s3-error make-s3-client "Must provide secret key" "secret-key"))) + (S3 (make-s3-client endpoint access-key secret-key region)))) ; precomputed empty sha256 -(def emptySHA256 #u8(227 176 196 66 152 252 28 20 154 251 244 200 153 111 185 - 36 39 174 65 228 100 155 147 76 164 149 153 27 120 82 184 85)) +(def emptySHA256 (syntax-eval (sha256 #u8()))) (defstruct s3-client (endpoint access-key secret-key region) final: #t @@ -32,11 +45,7 @@ ; Initializes a `s3-client`. Primarily responsible for holding onto credentials (defmethod {:init! s3-client} - (lambda (self - (endpoint "s3.amazonaws.com") - (access-key (getenv "AWS_ACCESS_KEY_ID" #f)) - (secret-key (getenv "AWS_SECRET_ACCESS_KEY" #f)) - (region (getenv "AWS_DEFAULT_REGION" "us-east-1"))) + (lambda (self endpoint access-key secret-key region) (using (self :- s3-client) (set! self.endpoint endpoint) (set! self.access-key access-key) @@ -47,17 +56,18 @@ (defmethod {list-buckets s3-client} ; => (list : bucket) (lambda (self) (using (self :- s3-client) - (let* ((req (s3-request/error self verb: 'GET)) - (xml (s3-parse-xml req)) - (buckets (sxml-find xml (sxml-e? 's3:Buckets) sxml-children)) - (names (map (chain <> - (sxml-select <> (sxml-e? 's3:Name)) - (cadar <>) - (make-bucket self <> (s3-client-region self))) - buckets))) - ; buckets is #f if none are returned - (request-close req) - names)))) + (let* ((req (s3-request/error self verb: 'GET)) + (xml (s3-parse-xml req)) + (buckets (sxml-find xml (sxml-e? 's3:Buckets) sxml-children)) + (names (map (chain <> + (sxml-select <> (sxml-e? 's3:Name)) + (cadar <>) + (make-bucket self <> (s3-client-region self)) + (S3Bucket <>)) + buckets))) + ; buckets is #f if none are returned + (request-close req) + names)))) ;; NOTE: all bucket operations need the correct region for the bucket or they will 400 (defmethod {create-bucket! s3-client} @@ -72,8 +82,8 @@ (lambda (self bucket-name) (using (self :- s3-client) (if (s3-client::bucket-exists? self bucket-name) - (make-bucket self bucket-name self.region) - #f)))) + (S3Bucket (make-bucket self bucket-name self.region)) + (raise-s3-error s3-client::get-bucket "Bucket does not exist" bucket-name))))) ; Delete a bucket by name (defmethod {delete-bucket! s3-client} @@ -87,52 +97,52 @@ (defmethod {bucket-exists? s3-client} (lambda (self bucket) (using (self :- s3-client) - (let* ((bucket (if (bucket? bucket) (bucket-name bucket) bucket)) - (req {self.request verb: 'HEAD bucket: bucket}) - (code (request-status req))) - ; 200 and 404 are expected codes - ; we explicitly handle 404 so we get proper predicate - ; semantics and don't raise on what would otherwise be - ; #f condition. - (if (memv code [200 404]) - (begin - (request-close req) - (= code 200)) - (with-request-error req)))))) + (let* ((bucket (if (bucket? bucket) (bucket-name bucket) bucket)) + (req {self.request verb: 'HEAD bucket: bucket}) + (code (request-status req))) + ; 200 and 404 are expected codes + ; we explicitly handle 404 so we get proper predicate + ; semantics and don't raise on what would otherwise be + ; #f condition. + (if (memq code [200 404]) + (begin + (request-close req) + (= code 200)) + (with-request-error req)))))) (defmethod {bucket s3-client} (lambda (self name) (using (self self :- s3-client) (if (s3-client::bucket-exists? self name) - (make-bucket self name (s3-client-region self)) - #f)))) + (S3Bucket (make-bucket self name (s3-client-region self))) + (raise-s3-error s3-client::bucket "bucket does not exist" name))))) ; Lists the objects stored within the bucket (defmethod {list-objects bucket} (lambda (self) (using ((self self :- bucket) - (client (bucket-client self) : s3-client)) - (let* ((name (bucket-name self)) - (req (s3-request/error client verb: 'GET bucket: name)) - (xml (s3-parse-xml req)) - (keys (sxml-select xml (sxml-e? 's3:Key) cadr))) - (request-close req) - keys)))) + (client (self.client) :- s3-client)) + (let* ((name (bucket-name self)) + (req (s3-request/error client verb: 'GET bucket: name)) + (xml (s3-parse-xml req)) + (keys (sxml-select xml (sxml-e? 's3:Key) cadr))) + (request-close req) + keys)))) (defmethod {get bucket} (lambda (self key) - (using ((self self : bucket) - (client (bucket-client self) : s3-client)) - (let* ((req (s3-request/error client verb: 'GET bucket: (bucket-name self) - path: (string-append "/" key))) - (data (request-content req))) - (request-close req) - data)))) + (using ((self :- bucket) + (client (self.client) :- s3-client)) + (let* ((req (s3-request/error client verb: 'GET bucket: (bucket-name self) + path: (string-append "/" key))) + (data (request-content req))) + (request-close req) + data)))) (defmethod {put! bucket} (lambda (self key data content-type: (content-type "binary/octet-stream")) - (using ((self self : bucket) - (client (bucket-client self) : s3-client)) + (using ((self :- bucket) + (client (self.client) :- s3-client)) (let (req (s3-request/error client verb: 'PUT bucket: (bucket-name self) path: (string-append "/" key) body: data @@ -143,7 +153,7 @@ (defmethod {delete! bucket} (lambda (self key) (using ((self :- bucket) - (client (bucket-client self) : s3-client)) + (client (self.client) :- s3-client)) (let (req (s3-request/error client verb: 'DELETE bucket: (bucket-name self) path: (string-append "/" key))) (request-close req) @@ -152,23 +162,23 @@ (defmethod {copy-to! bucket} (lambda (self src dest) (using ((self :- bucket) - (client (bucket-client self) : s3-client)) - (let* ((headers [["x-amz-copy-source" :: src]]) - (req (s3-client::request client - verb: 'PUT - bucket: (bucket-name self) - path: (string-append "/" dest) - extra-headers: headers)) - (error (s3-response-error? (s3-parse-xml req)))) - (request-close req) - (when error - (raise-s3-error - bucket::copy-to! - "Unable to perform server-side copy" - ; when error isn't empty, it should be a parsed XML tree - (sxml-find error (sxml-e? 'Code) cadr) - (request-status-text req))) - (void))))) + (client (self.client) :- s3-client)) + (let* ((headers [["x-amz-copy-source" :: src]]) + (req (s3-client::request client + verb: 'PUT + bucket: (bucket-name self) + path: (string-append "/" dest) + extra-headers: headers)) + (error (s3-response-error? (s3-parse-xml req)))) + (request-close req) + (when error + (raise-s3-error + bucket::copy-to! + "Unable to perform server-side copy" + ; when error isn't empty, it should be a parsed XML tree + (sxml-find error (sxml-e? 'Code) cadr) + (request-status-text req))) + (void))))) ; The core request method. Handles AWS Sig. v4, auth, and calls correct http- function based on @@ -184,40 +194,40 @@ extra-headers: (extra-headers #f) content-type: (content-type #f)) ; must be specified if body is specified (using (self :- s3-client) - (let* ((now (current-date)) - (ts (date->string now "~Y~m~dT~H~M~SZ")) - (scopets (date->string now "~Y~m~d")) - (scope (string-append scopets "/" (s3-client-region self) "/s3")) - (hash (if body (sha256 body) emptySHA256)) - (host (if bucket - (string-append bucket "." (s3-client-endpoint self)) - (s3-client-endpoint self))) - (headers [["Host" :: (string-append host ":443")] - ["x-amz-date" :: ts] - ["x-amz-content-sha256" :: (hex-encode hash)] - (if body [["Content-Type" :: content-type]] []) ... - (if extra-headers extra-headers []) ...]) - (creq (aws4-canonical-request - verb: verb - uri: path - query: query - headers: headers - hash: hash)) - (headers [["Authorization" :: (aws4-auth scope creq ts headers - (s3-client-secret-key self) (s3-client-access-key self))] - :: headers]) - (url (string-append "https://" host path))) - (case verb - ((GET) - (http-get url headers: headers params: query)) - ((PUT) - (http-put url headers: headers params: query data: body)) - ((DELETE) - (http-delete url headers: headers params: query)) - ((HEAD) - (http-head url headers: headers params: query)) - (else - (error "Bad request verb" verb))))))) + (let* ((now (current-date)) + (ts (date->string now "~Y~m~dT~H~M~SZ")) + (scopets (date->string now "~Y~m~d")) + (scope (string-append scopets "/" (s3-client-region self) "/s3")) + (hash (if body (sha256 body) emptySHA256)) + (host (if bucket + (string-append bucket "." (s3-client-endpoint self)) + (s3-client-endpoint self))) + (headers [["Host" :: (string-append host ":443")] + ["x-amz-date" :: ts] + ["x-amz-content-sha256" :: (hex-encode hash)] + (if body [["Content-Type" :: content-type]] []) ... + (if extra-headers extra-headers []) ...]) + (creq (aws4-canonical-request + verb: verb + uri: path + query: query + headers: headers + hash: hash)) + (headers [["Authorization" :: (aws4-auth scope creq ts headers + (s3-client-secret-key self) (s3-client-access-key self))] + :: headers]) + (url (string-append "https://" host path))) + (case verb + ((GET) + (http-get url headers: headers params: query)) + ((PUT) + (http-put url headers: headers params: query data: body)) + ((DELETE) + (http-delete url headers: headers params: query)) + ((HEAD) + (http-head url headers: headers params: query)) + (else + (error "Bad request verb" verb))))))) (defrule (s3-request/error self ...) (with-request-error diff --git a/src/std/net/s3/interface.ss b/src/std/net/s3/interface.ss index e688146a49..4175e684ef 100644 --- a/src/std/net/s3/interface.ss +++ b/src/std/net/s3/interface.ss @@ -4,7 +4,7 @@ (export #t) -(interface BucketMap +(interface S3 (get-bucket (name :~ string?)) (create-bucket! (name :~ string?) (opts :~ (maybe alist?) := #f)) @@ -12,7 +12,7 @@ (bucket-exists? (name :~ string?)) (list-buckets)) -(interface ObjectMap +(interface S3Bucket (get (name :~ string?)) (put! (name :~ string?) (data :~ u8vector?)