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