aws/request: make-operation->request: Use lowercase for authorization.
[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 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)))))))