Add support for Cost Explorer API.
[software/guile-aws.git] / aws / request.scm
1 ;;; guile-aws --- Scheme DSL for the AWS APIs
2 ;;; Copyright © 2019, 2020, 2021 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 (aws serialize)
21 #:use-module (ice-9 match)
22 #:use-module (ice-9 format)
23 #:use-module (srfi srfi-1)
24 #:use-module (srfi srfi-19)
25 #:use-module (srfi srfi-26)
26 #:use-module (gcrypt hash)
27 #:use-module (gcrypt hmac)
28 #:use-module (rnrs bytevectors)
29 #:use-module (web client)
30 #:use-module ((web response) #:select (response-content-type))
31 #:use-module ((web http) #:select (header-writer declare-header!))
32 #:use-module (sxml simple)
33 #:use-module (json)
34 #:export (%aws-default-region
35 %aws-access-key
36 %aws-secret-access-key
37
38 make-operation->request))
39
40 ;;; Commentary:
41
42 ;;; See: http://docs.aws.amazon.com/general/latest/gr/sigv4_signing.html
43 ;;; Make a request to the AWS API and pass request parameters in the
44 ;;; body of the request. Auth information is provided in an
45 ;;; Authorization header.
46
47 ;;; Code:
48
49 (define %aws-default-region
50 (make-parameter (or (getenv "AWS_DEFAULT_REGION")
51 "us-west-2")))
52
53 (define %aws-access-key
54 (make-parameter (getenv "AWS_ACCESS_KEY_ID")))
55
56 (define %aws-secret-access-key
57 (make-parameter (getenv "AWS_SECRET_ACCESS_KEY")))
58
59 (define algorithm "AWS4-HMAC-SHA256")
60
61 (define (sign key msg)
62 "Sign the string MSG with the secret key KEY (a bytevector) using the SHA256 algorithm."
63 (sign-data key (string->utf8 msg) #:algorithm 'sha256))
64
65 (define (hexify bv)
66 (format #f "~{~2,'0x~}" (bytevector->u8-list bv)))
67
68 ;; XXX: Guile's default-val-writer corrupts the Authorization header,
69 ;; because it wraps the value of the SignedHeaders field in quotes.
70 ;; This confuses AWS.
71 (define put-string (@@ (web http) put-string))
72 (define put-symbol (@@ (web http) put-symbol))
73 (define put-char (@@ (web http) put-char))
74 (define write-qstring (@@ (web http) write-qstring))
75 (define (my-val-writer k val port)
76 (if (or (string-index val #\,)
77 (string-index val #\"))
78 (write-qstring val port)
79 (put-string port val)))
80 (declare-header! "authorization"
81 (@@ (web http) parse-credentials)
82 (@@ (web http) validate-credentials)
83 (lambda (val port)
84 (match val
85 ((scheme . params)
86 (put-symbol port scheme)
87 (put-char port #\space)
88 ((@@ (web http) write-key-value-list) params port my-val-writer)))))
89
90 \f
91 (define (request-query-string operation-name api-version input)
92 "Return a request query string."
93 (string-join (cons* (format #false "Action=~a" operation-name)
94 (format #false "Version=~a" api-version)
95 (if input
96 (serialize-aws-value input)
97 '()))
98 "&"))
99
100 (define (input-arguments->scm input)
101 "Return the arguments of the INPUT value as an alist. Drop the
102 operation name."
103 (match (aws-value->scm input)
104 (((op-name . params)) params)))
105
106 (define (request-json-string input)
107 "Return a request JSON block. Drop the operation name as it is
108 already mentioned in the request headers."
109 (scm->json-string (input-arguments->scm input)))
110
111 (define (request-xml-string xmlns input)
112 "Return a request payload in XML format. Include the URI of the XML
113 namespace provided in the alist XMLNS."
114 (let* ((tree (aws-value->sxml input))
115 (tree-with-ns
116 (match tree
117 (((first . rest))
118 (let ((ns-uri
119 (and=> xmlns (lambda (ns)
120 (assoc-ref ns "uri")))))
121 (if ns-uri
122 (list (cons* first `(@ (xmlns ,ns-uri)) rest))
123 tree))))))
124 (call-with-output-string
125 (lambda (port)
126 (sxml->xml tree-with-ns port)))))
127
128 (define (parameterize-request-uri request-format-string input)
129 "Process the format string URL in REQUEST-FORMAT-STRING and replace
130 all placeholders (strings surrounded by curly braces) with their
131 corresponding value in INPUT."
132 (let ((arguments (input-arguments->scm input))
133 (parts (string-split request-format-string (char-set #\{ #\}))))
134 ;; Every second item corresponds to a placeholder.
135 (string-join (map (lambda (part index)
136 (if (odd? index)
137 (or (assoc-ref arguments part)
138 (error (format #false
139 "Cannot parameterize URL `~a'; missing value `~a'~%"
140 request-format-string part)))
141 part))
142 parts
143 (iota (length parts)))
144 "")))
145
146 (define* (make-operation->request api-metadata)
147 "Return a procedure that accepts an operation and returns an HTTP request."
148 (define endpoint-prefix
149 (assoc-ref api-metadata 'endpointPrefix))
150 (define service-name endpoint-prefix)
151 (define api-version
152 (assoc-ref api-metadata 'apiVersion))
153
154 (lambda* (#:key
155 http operation-name
156 xml-namespace
157 input)
158 (define region (%aws-default-region))
159 (define access-key
160 (or (%aws-access-key)
161 (error "No access key available. Set the AWS_ACCESS_KEY_ID environment variable.")))
162 (define secret-key
163 (or (%aws-secret-access-key)
164 (error "No secret access key available. Set the AWS_SECRET_ACCESS_KEY environment variable.")))
165 (define method
166 (assoc-ref http "method"))
167 (define host
168 (or (assoc-ref api-metadata 'globalEndpoint)
169 (string-join (list endpoint-prefix
170 region
171 "amazonaws.com")
172 ".")))
173 (define endpoint
174 (or (getenv "GUILE_AWS_DEBUG_ENDPOINT")
175 (string-append "https://" host)))
176 (define json?
177 (match (assoc-ref api-metadata 'protocol)
178 ((or "json" "rest-json") #true)
179 (_ #false)))
180 (define content-type
181 (if json?
182 `(,(string->symbol
183 (string-append "application/x-amz-json-"
184 (or (assoc-ref api-metadata 'jsonVersion)
185 "1.0")))
186 (charset . "utf-8"))
187 '(application/x-www-form-urlencoded (charset . "utf-8"))))
188
189 ;; DynamoDB (and possibly other JSON APIs) needs this, query
190 ;; string APIs do not.
191 (define amz-target (and=> (assoc-ref api-metadata 'targetPrefix)
192 (cut string-append <> "."
193 operation-name)))
194
195 (define request-parameters
196 (match (assoc-ref api-metadata 'protocol)
197 ((or "json"
198 "rest-json")
199 (request-json-string input))
200 ("rest-xml"
201 (request-xml-string xml-namespace input))
202 (_
203 (request-query-string operation-name api-version input))))
204
205 (define payload-hash
206 (hexify (sha256 (string->utf8 request-parameters))))
207
208 (define now (current-date 0))
209 (define amz-date
210 (date->string now "~Y~m~dT~H~M~SZ"))
211 (define date-stamp
212 (date->string now "~Y~m~d"))
213
214 \f
215 ;; https://docs.aws.amazon.com/general/latest/gr/sigv4-create-canonical-request.html
216 (define canonical-uri
217 (or (and=> (assoc-ref http "requestUri")
218 (lambda (format-string)
219 (parameterize-request-uri format-string input)))
220 "/"))
221
222 (define headers
223 (filter cdr `((content-type . ,content-type)
224 (host . (,host . #f))
225 (x-amz-content-sha256 . ,payload-hash)
226 (x-amz-date . ,amz-date)
227 (x-amz-target . ,amz-target))))
228 (define authorization-header
229 (let* ((canonical-headers
230 ;; Header names must be trimmed, lower-case, sorted in
231 ;; code point order from low to high! Note: there must
232 ;; be a trailing newline character.
233 (string-join (map (match-lambda
234 ((key . value)
235 (string-append (symbol->string key) ":"
236 (with-output-to-string
237 (lambda ()
238 ((header-writer key) value (current-output-port)))))))
239 headers)
240 "\n" 'suffix))
241 (signed-headers
242 ;; This lists the headers in the canonical-headers list,
243 ;; delimited with ";" and in alpha order. The request
244 ;; can include any headers; canonical-headers and
245 ;; signed-headers include those that you want to be
246 ;; included in the hash of the request. "Host" and
247 ;; "x-amz-date" are always required.
248 (string-join (map (compose symbol->string first) headers) ";"))
249 ;; The query string is blank because parameters are passed
250 ;; in the body of the request.
251 (canonical-querystring "")
252 (canonical-request
253 (string-join (list method
254 canonical-uri
255 canonical-querystring
256 canonical-headers
257 signed-headers
258 payload-hash)
259 "\n"))
260 (credential-scope
261 (string-join (list date-stamp
262 region
263 service-name
264 "aws4_request") "/"))
265 (string-to-sign
266 (string-join (list algorithm
267 amz-date
268 credential-scope
269 (hexify (sha256 (string->utf8 canonical-request))))
270 "\n"))
271 (signature
272 (let* ((kdate (sign (string->utf8 (string-append "AWS4" secret-key)) date-stamp))
273 (kregion (sign kdate region))
274 (kservice (sign kregion service-name))
275 (signing-key (sign kservice "aws4_request")))
276 (hexify (sign signing-key string-to-sign)))))
277 `(,(string->symbol algorithm)
278 (Credential . ,(string-append access-key "/" credential-scope))
279 (SignedHeaders . ,signed-headers)
280 (Signature . ,signature))))
281
282 ;; For DynamoDB, the request can include any headers, but MUST
283 ;; include "host", "x-amz-date", "x-amz-target", "content-type",
284 ;; and "Authorization". Except for the authorization header, the
285 ;; headers must be included in the canonical-headers and
286 ;; signed-headers values, as noted earlier. Order here is not
287 ;; significant.
288 (define new-headers
289 (cons `(authorization . ,authorization-header)
290 (filter cdr headers)))
291
292 (call-with-values
293 (lambda ()
294 (http-request (string-append endpoint canonical-uri)
295 #:method (string->symbol method)
296 #:body (string->utf8 request-parameters)
297 #:headers new-headers))
298 (lambda (response body)
299 (let ((server-text (match body
300 ((? bytevector? bv)
301 (utf8->string bv))
302 ((? string? s) s)
303 (anything anything))))
304 (match (response-content-type response)
305 ((or ('application/x-amz-json-1.1 . rest)
306 ('application/json . rest))
307 (or (and=> server-text json-string->scm)
308 #true))
309 (('text/xml . rest)
310 (or (and=> server-text xml->sxml)
311 #true))
312 (_ server-text)))))))