aws/request: make-operation->request: Define PAYLOAD-HASH.
[software/guile-aws.git] / 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 (serialize-aws-value input))
155 "&"))
156
157 (define payload-hash
158 (hexify (sha256 (string->utf8 request-parameters))))
159
160 (define now (current-date 0))
161 (define amz-date
162 (date->string now "~Y~m~dT~H~M~SZ"))
163 (define date-stamp
164 (date->string now "~Y~m~d"))
165
166 \f
167 ;; https://docs.aws.amazon.com/general/latest/gr/sigv4-create-canonical-request.html
168
169 ;; TODO: Create canonical URI--the part of the URI from domain to query
170 ;; string (use '/' if no path)
171 (define canonical-uri "/")
172
173 (define headers
174 (filter cdr `((content-type . ,content-type)
175 (host . (,host . #f))
176 (x-amz-date . ,amz-date)
177 (x-amz-target . ,amz-target))))
178 (define authorization-header
179 (let* ((canonical-headers
180 ;; Header names must be trimmed, lower-case, sorted in
181 ;; code point order from low to high! Note: there must
182 ;; be a trailing newline character.
183 (string-join (map (match-lambda
184 ((key . value)
185 (string-append (symbol->string key) ":"
186 (with-output-to-string
187 (lambda ()
188 ((header-writer key) value (current-output-port)))))))
189 headers)
190 "\n" 'suffix))
191 (signed-headers
192 ;; This lists the headers in the canonical-headers list,
193 ;; delimited with ";" and in alpha order. The request
194 ;; can include any headers; canonical-headers and
195 ;; signed-headers include those that you want to be
196 ;; included in the hash of the request. "Host" and
197 ;; "x-amz-date" are always required.
198 (string-join (map (compose symbol->string first) headers) ";"))
199 ;; The query string is blank because parameters are passed
200 ;; in the body of the request.
201 (canonical-querystring "")
202 (canonical-request
203 (string-join (list method
204 canonical-uri
205 canonical-querystring
206 canonical-headers
207 signed-headers
208 payload-hash)
209 "\n"))
210 (credential-scope
211 (string-join (list date-stamp
212 region
213 service-name
214 "aws4_request") "/"))
215 (string-to-sign
216 (string-join (list algorithm
217 amz-date
218 credential-scope
219 (hexify (sha256 (string->utf8 canonical-request))))
220 "\n"))
221 (signature
222 (let* ((kdate (sign (string->utf8 (string-append "AWS4" secret-key)) date-stamp))
223 (kregion (sign kdate region))
224 (kservice (sign kregion service-name))
225 (signing-key (sign kservice "aws4_request")))
226 (hexify (sign signing-key string-to-sign)))))
227 `(,(string->symbol algorithm)
228 (Credential . ,(string-append access-key "/" credential-scope))
229 (SignedHeaders . ,signed-headers)
230 (Signature . ,signature))))
231
232 ;; For DynamoDB, the request can include any headers, but MUST
233 ;; include "host", "x-amz-date", "x-amz-target", "content-type",
234 ;; and "Authorization". Except for the authorization header, the
235 ;; headers must be included in the canonical-headers and
236 ;; signed-headers values, as noted earlier. Order here is not
237 ;; significant.
238 (define new-headers
239 (cons `(Authorization . ,authorization-header)
240 (filter cdr headers)))
241
242 (call-with-values
243 (lambda ()
244 (http-post endpoint
245 ;#:method (string->symbol method)
246 #:body (string->utf8 request-parameters)
247 #:headers new-headers))
248 (lambda (response body)
249 (xml->sxml (match body
250 ((? bytevector? bv)
251 (utf8->string bv))
252 ((? string? s) s)))))))