Adds basic AWS S3 client

Includes support for:
- Bucket get/set/list/delete/exists?
- Server-side object copying
- Object get/set/list/delete
- Bucket exists

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"

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))

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))))))

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))

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-string<? a b)
+  (string<? (car a) (car b)))
+
+(def (canonical-repr val)
+  (uri-encode
+   (with-output-to-string []
+     (cut display val))))
+
+(def (canonical-query-string query)
+  (let* ((query (map (lambda (q)
+                       (cons (car q)
+                             (canonical-repr (cdr q))))
+                     query))
+         (query (sort query car-string<?)))
+    (string-join
+     (map (lambda (q) (string-append (car q) "=" (cdr q))) query)
+     "&")))
+
+(def (canonical-headers headers)
+  (let* ((headers (map (lambda (h)
+                         (cons (string-downcase (car h))
+                               (cdr h)))
+                       headers))
+         (headers (sort headers car-string<?)))
+    (apply string-append
+      (map (lambda (h) (string-append (car h) ":" (cdr h) "\n")) headers))))
+
+(def (signed-headers headers)
+  (string-join
+   (sort (map (lambda (h) (string-downcase (car h))) headers)
+         string<?)
+   ";"))
+
+(def (signing-key scope secret-key)
+  ;; TODO cache signing keys
+  (match (string-split scope #\/)
+    ([date region service]
+     (let* ((date-key
+             (hmac-sha256 (string->bytes
+                           (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))))