e0cf58fd6f69a4a0806c550e5b55c3fd8b7c96e0
[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 (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-date . ,amz-date)
179 (x-amz-target . ,amz-target))))
180 (define authorization-header
181 (let* ((canonical-headers
182 ;; Header names must be trimmed, lower-case, sorted in
183 ;; code point order from low to high! Note: there must
184 ;; be a trailing newline character.
185 (string-join (map (match-lambda
186 ((key . value)
187 (string-append (symbol->string key) ":"
188 (with-output-to-string
189 (lambda ()
190 ((header-writer key) value (current-output-port)))))))
191 headers)
192 "\n" 'suffix))
193 (signed-headers
194 ;; This lists the headers in the canonical-headers list,
195 ;; delimited with ";" and in alpha order. The request
196 ;; can include any headers; canonical-headers and
197 ;; signed-headers include those that you want to be
198 ;; included in the hash of the request. "Host" and
199 ;; "x-amz-date" are always required.
200 (string-join (map (compose symbol->string first) headers) ";"))
201 ;; The query string is blank because parameters are passed
202 ;; in the body of the request.
203 (canonical-querystring "")
204 (canonical-request
205 (string-join (list method
206 canonical-uri
207 canonical-querystring
208 canonical-headers
209 signed-headers
210 payload-hash)
211 "\n"))
212 (credential-scope
213 (string-join (list date-stamp
214 region
215 service-name
216 "aws4_request") "/"))
217 (string-to-sign
218 (string-join (list algorithm
219 amz-date
220 credential-scope
221 (hexify (sha256 (string->utf8 canonical-request))))
222 "\n"))
223 (signature
224 (let* ((kdate (sign (string->utf8 (string-append "AWS4" secret-key)) date-stamp))
225 (kregion (sign kdate region))
226 (kservice (sign kregion service-name))
227 (signing-key (sign kservice "aws4_request")))
228 (hexify (sign signing-key string-to-sign)))))
229 `(,(string->symbol algorithm)
230 (Credential . ,(string-append access-key "/" credential-scope))
231 (SignedHeaders . ,signed-headers)
232 (Signature . ,signature))))
233
234 ;; For DynamoDB, the request can include any headers, but MUST
235 ;; include "host", "x-amz-date", "x-amz-target", "content-type",
236 ;; and "Authorization". Except for the authorization header, the
237 ;; headers must be included in the canonical-headers and
238 ;; signed-headers values, as noted earlier. Order here is not
239 ;; significant.
240 (define new-headers
241 (cons `(Authorization . ,authorization-header)
242 (filter cdr headers)))
243
244 (call-with-values
245 (lambda ()
246 (http-post endpoint
247 ;#:method (string->symbol method)
248 #:body (string->utf8 request-parameters)
249 #:headers new-headers))
250 (lambda (response body)
251 (xml->sxml (match body
252 ((? bytevector? bv)
253 (utf8->string bv))
254 ((? string? s) s)))))))