Skip to content

Commit

Permalink
Address review comments, see extra...
Browse files Browse the repository at this point in the history 
* Raise exceptions instead of return #f
* Don't export structs, create a constructor that wraps the return value
  in the interface
* Raise error when credentials are not supplied
* memv -> memq for speed
* more appropriate use of (using ...)
* Renames interfaces to be more clear
  • Loading branch information
@chiefnoah
chiefnoah committed Oct 21, 2023
1 parent 255728c commit 60e1c5c
Show file tree
Hide file tree
Showing 2 changed files with 115 additions and 105 deletions.
216 changes: 113 additions & 103 deletions src/std/net/s3/api.ss
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,7 @@
;;; (C) vyzo
;;; AWS S3 client
(import "sigv4"
"interface"
:std/net/request
:std/misc/func
:std/contract
Expand All @@ -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
Expand All @@ -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)
Expand All @@ -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}
Expand All @@ -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}
Expand All @@ -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
Expand All @@ -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)
Expand All @@ -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
Expand All @@ -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
Expand Down
4 changes: 2 additions & 2 deletions src/std/net/s3/interface.ss
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,15 +4,15 @@

(export #t)

(interface BucketMap
(interface S3
(get-bucket (name :~ string?))
(create-bucket! (name :~ string?)
(opts :~ (maybe alist?) := #f))
(delete-bucket! (name :~ string?))
(bucket-exists? (name :~ string?))
(list-buckets))

(interface ObjectMap
(interface S3Bucket
(get (name :~ string?))
(put! (name :~ string?)
(data :~ u8vector?)
Expand Down

0 comments on commit 60e1c5c

Please sign in to comment.