diff --git a/src/std/build-spec.ss b/src/std/build-spec.ss index 004805b577..4d64a47db9 100644 --- a/src/std/build-spec.ss +++ b/src/std/build-spec.ss @@ -217,6 +217,10 @@ "net/uri" "net/request" "net/json-rpc" + "net/s3" + "net/s3/interface" + "net/s3/api" + "net/s3/sigv4" "net/websocket/interface" "net/websocket/socket" "net/websocket/client" diff --git a/src/std/net/s3.ss b/src/std/net/s3.ss new file mode 100644 index 0000000000..c0056d8097 --- /dev/null +++ b/src/std/net/s3.ss @@ -0,0 +1,5 @@ +;;; -*- Gerbil -*- +;;; © vyzo, ngp +;;; AWS S3 Client +(import ./s3/api ./s3/interface) +(export (import: ./s3/api) (import: ./s3/interface)) diff --git a/src/std/net/s3/api.ss b/src/std/net/s3/api.ss new file mode 100644 index 0000000000..378276cc98 --- /dev/null +++ b/src/std/net/s3/api.ss @@ -0,0 +1,242 @@ +;;; -*- Gerbil -*- +;;; (C) vyzo +;;; AWS S3 client +(import "sigv4" + :std/net/request + :std/misc/func + :std/contract + :std/net/uri + :std/crypto/digest + :std/text/hex + :std/xml + :std/error + :std/sugar + :std/srfi/19) +(export (struct-out s3-client bucket) S3ClientError) + +; 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)) + +(defstruct s3-client (endpoint access-key secret-key region) + final: #t + constructor: :init!) + +(defstruct bucket (client name region) + final: #t) + +(deferror-class (S3ClientError Error) () s3-client-error?) + +(defraise/context (raise-s3-error where message irritants ...) + (S3ClientError message irritants: [irritants ...])) + +; 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"))) + (using (self self : s3-client) + (set! self.endpoint endpoint) + (set! self.access-key access-key) + (set! self.secret-key secret-key) + (set! self.region region)))) + +; Retrieves buckets accessible to this client. +(defmethod {list-buckets s3-client} ; => (list : bucket) + (lambda (self) + (using (self 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)))) + +;; NOTE: all bucket operations need the correct region for the bucket or they will 400 +(defmethod {create-bucket! s3-client} + (lambda (self bucket) + (using (self self : s3-client) + (let (req (s3-request/error self verb: 'PUT bucket: bucket)) + (request-close req) + (void))))) + +; Gets a bucket struct that can be used to fetch objects. +(defmethod {get-bucket s3-client} ; => bucket + (lambda (self bucket-name) + (using (self self : s3-client) + (if {bucket-exists? self bucket-name} + (make-bucket self bucket-name self.region) + #f)))) + +; Delete a bucket by name +(defmethod {delete-bucket! s3-client} + (lambda (self bucket) + (using ((self self : s3-client) + (bucket bucket :~ string?)) + (when {bucket-exists? self bucket} + (let (req (s3-request/error self verb: 'DELETE bucket: bucket)) + (request-close req) + (void)))))) + +(defmethod {bucket-exists? s3-client} + (lambda (self bucket) + (using (self 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)))))) + +(defmethod {bucket s3-client} + (lambda (self name) + (using (self self : s3-client) + (if {bucket-exists? self name} + (make-bucket self name (s3-client-region self)) + #f)))) + +; 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)))) + +(defmethod {get bucket} + (lambda (self key) + (using ((self self : bucket) + (key :~ string?) + (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)))) + +(defmethod {put! bucket} + (lambda (self key data content-type: (content-type "binary/octet-stream")) + (using ((self self : bucket) + (key :~ string?) + (client (bucket-client self) : s3-client)) + (let (req (s3-request/error client verb: 'PUT bucket: (bucket-name self) + path: (string-append "/" key) + body: data + content-type: content-type)) + (request-close req) + (void))))) + +(defmethod {delete! bucket} + (lambda (self key) + (using ((self : bucket) + (key :~ string?) + (client (bucket-client self) : s3-client)) + (let (req (s3-request/error client verb: 'DELETE bucket: (bucket-name self) + path: (string-append "/" key))) + (request-close req) + (void))))) + +(defmethod {copy-to! bucket} + (lambda (self src-bucket src dest) + (using ((self : bucket) + (client (bucket-client self) : s3-client) + ; a bucket instance pointing to the intended source bucket + (src-bucket : bucket) + ; the source file name + (src :~ string?) + ; the destination file name + (dest :~ string?)) + (let* ((src-ident (string-append (bucket-name src-bucket) "/" src)) + (headers [["x-amz-copy-source" :: src-ident]]) + (req (s3-request/error client + verb: 'PUT + bucket: (bucket-name self) + path: (string-append "/" dest) + extra-headers: headers))) + (request-close req) + (void))))) + + +; The core request method. Handles AWS Sig. v4, auth, and calls correct http- function based on +; `verb`. +(defmethod {request s3-client} + (lambda (self + verb: (verb 'GET) + bucket: (bucket #f) + path: (path "/") + query: (query #f) + body: (body #f) + ; optional extra headers + extra-headers: (extra-headers #f) + content-type: (content-type #f)) ; must be specified if body is specified + (using (self 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))))))) + +(defrule (s3-request/error self ...) + (with-request-error + {request self ...})) + +(def (s3-parse-xml req) + (read-xml (request-content req) + namespaces: '(("http://s3.amazonaws.com/doc/2006-03-01/" . "s3")))) + +(def (with-request-error req) + (using (req :~ request?) + (if (and (fx>= (request-status req) 200) + (fx< (request-status req) 300)) + req + (begin + (request-close req) + (raise-s3-error + (request-status req) + (request-status-text req)))))) diff --git a/src/std/net/s3/interface.ss b/src/std/net/s3/interface.ss new file mode 100644 index 0000000000..70134f86fd --- /dev/null +++ b/src/std/net/s3/interface.ss @@ -0,0 +1,22 @@ +(import :std/interface + :std/contract + :std/misc/alist) + +(export #t) + +(interface BucketMap + (get-bucket (name :~ string?)) + (create-bucket! (name :~ string?) + (opts :~ (maybe alist?) := #f)) + (delete-bucket! (name :~ string?)) + (bucket-exists? (name :~ string?)) + (list-buckets)) + +(interface ObjectMap + (get (name :~ string?)) + (put! (name :~ string?) + (data :~ u8vector?) + ; Additional options. See implementation for additional details + (opts :~ (maybe alist?) := #f)) + (delete! (name :~ string?)) + (list-objects)) diff --git a/src/std/net/s3/sigv4.ss b/src/std/net/s3/sigv4.ss new file mode 100644 index 0000000000..d029ca50e2 --- /dev/null +++ b/src/std/net/s3/sigv4.ss @@ -0,0 +1,106 @@ +;;; -*- Gerbil -*- +;;; (C) vyzo +;;; AWS sigv4 request signatures +(import :std/misc/bytes + :std/srfi/13 + :std/crypto/digest + :std/crypto/hmac + :std/text/hex + :std/net/uri + :std/contract + :std/sort) +(export aws4-canonical-request aws4-sign aws4-auth) + +;; Reference: http://docs.aws.amazon.com/AmazonS3/latest/API/sig-v4-header-based-auth.html + +;; create a canonical request string for signing +(def (aws4-canonical-request + verb: verb ; symbol -- http verb (GET PUT DELETE ...) + uri: uri ; string -- canonical request uri + query: query ; [[string . value] ...] -- query parameters + headers: headers ; [[string . value] ...] -- signed request headers + hash: hash ; bytes -- SHA256 content hash + ) + (string-append + (symbol->string verb) "\n" + uri "\n" + (if query (canonical-query-string query) "") "\n" + (canonical-headers headers) "\n" + (signed-headers headers) "\n" + (hex-encode hash))) + +;; calculate a signature for a canonical request +;; scope is the request scope: string in the form yyyymmdd/region/service +;; ts is the request timestamp string +;; request is a the canonical request string +(def (aws4-sign scope request-str ts secret-key) + (let ((key (signing-key scope secret-key)) + (str (string-to-sign scope request-str ts))) + (hmac-sha256 key (string->bytes str)))) + +;; Calcuate the authorization header +(def (aws4-auth scope request-str ts headers secret-key access-key) + (let (sig (aws4-sign scope request-str ts secret-key)) + (string-append "AWS4-HMAC-SHA256 " + "Credential=" access-key "/" scope "/aws4_request," + "SignedHeaders=" (signed-headers headers) "," + "Signature=" (hex-encode sig)))) + +;;; internal +(def (car-stringbytes + (string-append "AWS4" secret-key)) + (string->bytes date))) + (date-region-key + (hmac-sha256 date-key + (string->bytes region))) + (date-region-svc-key + (hmac-sha256 date-region-key + (string->bytes service)))) + (hmac-sha256 date-region-svc-key + (@bytes "aws4_request")))) + (else + (error "Bad request scope; expected date/region/service string" scope)))) + +(def (string-to-sign scope req ts) + (string-append "AWS4-HMAC-SHA256\n" + ts "\n" + scope "/aws4_request" "\n" + (hex-encode (sha256 req))))