aws/request.scm

   1 ;;; guile-aws --- Scheme DSL for the AWS APIs
   2 ;;; Copyright © 2019, 2020 Ricardo Wurmus <rekado@elephly.net>
   3 ;;;
   4 ;;; Guile-AWS is free software: you can redistribute it and/or modify
   5 ;;; it under the terms of the GNU General Public License as published
   6 ;;; by the Free Software Foundation, either version 3 of the License,
   7 ;;; or (at your option) any later version.
   8 ;;;
   9 ;;; Guile-AWS is distributed in the hope that it will be useful, but
  10 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;;; General Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU General Public License
  15 ;;; along with this program.  If not, see
  16 ;;; <http://www.gnu.org/licenses/>.
  17
  18 (define-module (aws request)
  19   #:use-module (aws base)
  20   #:use-module (ice-9 match)
  21   #:use-module (ice-9 format)
  22   #:use-module (srfi srfi-1)
  23   #:use-module (srfi srfi-19)
  24   #:use-module (srfi srfi-26)
  25   #:use-module (gcrypt hash)
  26   #:use-module (gcrypt hmac)
  27   #:use-module (rnrs bytevectors)
  28   #:use-module (web client)
  29   #:use-module ((web http) #:select (header-writer))
  30   #:use-module (sxml simple)
  31   #:export (make-operation->request serialize-aws-value))
  32
  33 ;;; Commentary:
  34
  35 ;;; See: http://docs.aws.amazon.com/general/latest/gr/sigv4_signing.html
  36 ;;; Make a POST request and pass request parameters in the body of the
  37 ;;; request.  Auth information is provided in an Authorization header.
  38
  39 ;;; Code:
  40
  41 (define algorithm "AWS4-HMAC-SHA256")
  42
  43 (define (sign key msg)
  44   "Sign the string MSG with the secret key KEY (a bytevector) using the SHA256 algorithm."
  45   (sign-data key (string->utf8 msg) #:algorithm 'sha256))
  46
  47 (define (hexify bv)
  48   (format #f "~{~2,'0x~}" (bytevector->u8-list bv)))
  49
  50 ;; XXX: Guile's default-val-writer corrupts the Authorization header,
  51 ;; because it wraps the value of the SignedHeaders field in quotes.
  52 ;; This confuses AWS.
  53 (define (my-default-val-writer k val port)
  54   (if (or (string-index val #\,)
  55           (string-index val #\"))
  56       ((@@ (web http) write-qstring) val port)
  57       ((@@ (web http) put-string) port val)))
  58 (module-set!
  59  (resolve-module '(web http))
  60  'default-val-writer my-default-val-writer)
  61
  62 \f
  63 ;; See https://docs.aws.amazon.com/AWSEC2/latest/APIReference/Query-Requests.html
  64 (define* (serialize-aws-value thing #:key (path '()) n (depth 0))
  65   (define top? (zero? depth))
  66   (cond
  67    ((aws-structure? thing)
  68     (filter-map (lambda (member)
  69                   (match (aws-member-value member)
  70                     ('__unspecified__ #f)
  71                     (value
  72                      (serialize-aws-value value
  73                                           #:path
  74                                           (if top?
  75                                               (list (or (aws-member-location-name member)
  76                                                         (aws-member-name member)))
  77                                               (cons* (or (aws-member-location-name member)
  78                                                          (aws-member-name member))
  79                                                      n
  80                                                      (aws-structure-aws-name thing)
  81                                                      path))
  82                                           #:depth
  83                                           (1+ depth)))))
  84                 (aws-structure-members thing)))
  85    ((aws-shape? thing)
  86     (cond
  87      ((aws-shape-primitive? thing)
  88       (serialize-aws-value (aws-shape-value thing)
  89                            #:path path
  90                            #:depth (1+ depth)))
  91      (else
  92       (serialize-aws-value (aws-shape-value thing)
  93                            #:path
  94                            (cons (or (aws-shape-location-name thing)
  95                                      (aws-shape-aws-name thing)) path)
  96                            #:depth (1+ depth)))))
  97    ((boolean? thing)
  98     (serialize-aws-value (or (and thing "true") "false")
  99                          #:path path
 100                          #:depth (1+ depth)))
 101    ((list? thing)
 102     (append-map (lambda (item n)
 103                   (serialize-aws-value item
 104                                        #:path path
 105                                        #:n n
 106                                        #:depth (1+ depth)))
 107                 thing
 108                 (iota (length thing) 1)))
 109    (else (format #f "~a=~a"
 110                  (string-join (map (cut format #f "~a" <>)
 111                                    (reverse (filter identity path)))
 112                               ".")
 113                  thing))))
 114
 115 (define* (make-operation->request api-metadata)
 116   "Return a procedure that accepts an operation and returns an HTTP request."
 117   (define endpoint-prefix
 118     (assoc-ref api-metadata 'endpointPrefix))
 119   (define service-name endpoint-prefix)
 120   (define api-version
 121     (assoc-ref api-metadata 'apiVersion))
 122
 123   (lambda* (#:key http operation-name input)
 124     (define region
 125       (or (getenv "AWS_DEFAULT_REGION")
 126           "us-west-2"))
 127     (define access-key
 128       (or (getenv "AWS_ACCESS_KEY_ID")
 129           (error "No access key available.  Set the AWS_ACCESS_KEY_ID environment variable.")))
 130     (define secret-key
 131       (or (getenv "AWS_SECRET_ACCESS_KEY")
 132           (error "No secret access key available.  Set the AWS_SECRET_ACCESS_KEY environment variable.")))
 133     (define method
 134       (assoc-ref http "method"))
 135     (define host
 136       (string-join (list endpoint-prefix
 137                          region
 138                          "amazonaws.com")
 139                    "."))
 140     (define endpoint
 141       (string-append "https://" host "/"))
 142     (define content-type
 143       '(application/x-www-form-urlencoded (charset . "utf-8")))
 144
 145     ;; DynamoDB needs this, others don't.
 146     (define amz-target (and=> (assoc-ref api-metadata 'targetPrefix)
 147                               (cut string-append <> "."
 148                                    operation-name)))
 149
 150     ;; TODO: some APIs use JSON, others (like EC2) use plain query strings.
 151     (define request-parameters
 152       (string-join (cons* (format #f "Action=~a" operation-name)
 153                           (format #f "Version=~a" api-version)
 154                           (if input
 155                               (serialize-aws-value input)
 156                               '()))
 157                    "&"))
 158
 159     (define payload-hash
 160       (hexify (sha256 (string->utf8 request-parameters))))
 161
 162     (define now (current-date 0))
 163     (define amz-date
 164       (date->string now "~Y~m~dT~H~M~SZ"))
 165     (define date-stamp
 166       (date->string now "~Y~m~d"))
 167
 168     \f
 169     ;; https://docs.aws.amazon.com/general/latest/gr/sigv4-create-canonical-request.html
 170
 171     ;; TODO: Create canonical URI--the part of the URI from domain to query
 172     ;; string (use '/' if no path)
 173     (define canonical-uri "/")
 174
 175     (define headers
 176       (filter cdr `((content-type . ,content-type)
 177                     (host         . (,host . #f))
 178                     (x-amz-content-sha256 . ,payload-hash)
 179                     (x-amz-date   . ,amz-date)
 180                     (x-amz-target . ,amz-target))))
 181     (define authorization-header
 182       (let* ((canonical-headers
 183               ;; Header names must be trimmed, lower-case, sorted in
 184               ;; code point order from low to high!  Note: there must
 185               ;; be a trailing newline character.
 186               (string-join (map (match-lambda
 187                                   ((key . value)
 188                                    (string-append (symbol->string key) ":"
 189                                                   (with-output-to-string
 190                                                     (lambda ()
 191                                                       ((header-writer key) value (current-output-port)))))))
 192                                 headers)
 193                            "\n" 'suffix))
 194              (signed-headers
 195               ;; This lists the headers in the canonical-headers list,
 196               ;; delimited with ";" and in alpha order.  The request
 197               ;; can include any headers; canonical-headers and
 198               ;; signed-headers include those that you want to be
 199               ;; included in the hash of the request. "Host" and
 200               ;; "x-amz-date" are always required.
 201               (string-join (map (compose symbol->string first) headers) ";"))
 202              ;; The query string is blank because parameters are passed
 203              ;; in the body of the request.
 204              (canonical-querystring "")
 205              (canonical-request
 206               (string-join (list method
 207                                  canonical-uri
 208                                  canonical-querystring
 209                                  canonical-headers
 210                                  signed-headers
 211                                  payload-hash)
 212                            "\n"))
 213              (credential-scope
 214               (string-join (list date-stamp
 215                                  region
 216                                  service-name
 217                                  "aws4_request") "/"))
 218              (string-to-sign
 219               (string-join (list algorithm
 220                                  amz-date
 221                                  credential-scope
 222                                  (hexify (sha256 (string->utf8 canonical-request))))
 223                            "\n"))
 224              (signature
 225               (let* ((kdate       (sign (string->utf8 (string-append "AWS4" secret-key)) date-stamp))
 226                      (kregion     (sign kdate region))
 227                      (kservice    (sign kregion service-name))
 228                      (signing-key (sign kservice "aws4_request")))
 229                 (hexify (sign signing-key string-to-sign)))))
 230         `(,(string->symbol algorithm)
 231           (Credential . ,(string-append access-key "/" credential-scope))
 232           (SignedHeaders . ,signed-headers)
 233           (Signature . ,signature))))
 234
 235     ;; For DynamoDB, the request can include any headers, but MUST
 236     ;; include "host", "x-amz-date", "x-amz-target", "content-type",
 237     ;; and "Authorization".  Except for the authorization header, the
 238     ;; headers must be included in the canonical-headers and
 239     ;; signed-headers values, as noted earlier.  Order here is not
 240     ;; significant.
 241     (define new-headers
 242       (cons `(Authorization . ,authorization-header)
 243             (filter cdr headers)))
 244
 245     (call-with-values
 246         (lambda ()
 247           (http-post endpoint
 248                      ;#:method (string->symbol method)
 249                         #:body (string->utf8 request-parameters)
 250                         #:headers new-headers))
 251       (lambda (response body)
 252         (xml->sxml (match body
 253                      ((? bytevector? bv)
 254                       (utf8->string bv))
 255                      ((? string? s) s)))))))