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