base: aws-operation: Pass request arguments to request constructor.
[software/guile-aws.git] / language / aws / spec.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 (language aws spec)
19 #:use-module (aws base)
20 #:use-module (aws utils json)
21 #:use-module (ice-9 match)
22 #:use-module (srfi srfi-1)
23 #:use-module (srfi srfi-2)
24 #:use-module (system base language)
25 #:export (aws))
26
27 (define %shape-specs (list))
28
29 (define (primitive? exp)
30 (member (assoc-ref exp "type")
31 '("string"
32 "blob"
33 "boolean"
34 "timestamp"
35 "integer" "long"
36 "double" "float"
37 "list")))
38
39 (define (primitive-type-checker exp)
40 "Return an S-expression representation of a type checking procedure
41 for a shape expression EXP with a primitive data type. Throw an error
42 if this is not a primitive data type."
43 (match (assoc-ref exp "type")
44 ("string"
45 (let ((enum (and=> (assoc-ref exp "enum")
46 vector->list))
47 (min (assoc-ref exp "min"))
48 (max (assoc-ref exp "max")))
49 `(lambda (value)
50 (and (string? value)
51 ,(if enum
52 `(member value ',enum)
53 #true)
54 ,(if (or min max)
55 `(let ((len (string-length value)))
56 (and ,(if min `(>= len ,min) #true)
57 ,(if max `(<= len ,max) #true)))
58 #true)))))
59 ("blob" 'bytevector?)
60 ("boolean" 'boolean?)
61 ("timestamp" 'date?)
62 ((or "integer" "long")
63 `(lambda (value)
64 (let ((min ,(assoc-ref exp "min"))
65 (max ,(assoc-ref exp "max")))
66 (and (integer? value)
67 (if min (>= value min) #t)
68 (if max (<= value max) #t)))))
69 ((or "double" "float") 'real?)
70 ("list"
71 (let ((member-spec (assoc-ref exp "member")))
72 (if member-spec
73 (let ((shape-name (string->symbol (assoc-ref member-spec "shape"))))
74 `(lambda (value)
75 (let ((shape ',shape-name))
76 (and (list? value)
77 ;; Use the primitive type checker here as well
78 ;; in case the member spec is a wrapper around
79 ;; a primitive value.
80 (every ,(let ((target-spec (assoc-ref %shape-specs shape-name)))
81 (if (and=> target-spec primitive?)
82 ;; Apply the primitive type check
83 ;; directly. This allows us to
84 ;; avoid unnecessary wrapping.
85 (primitive-type-checker target-spec)
86 ;; Otherwise make sure the value has the correct type
87 '(lambda (item)
88 (and=> (aws-name item)
89 (cut eq? <> shape)))))
90 value)))))
91 'list?)))
92 ("map"
93 `(lambda (value)
94 (let ((key-shape
95 ',(string->symbol (assoc-ref (assoc-ref exp "key") "shape")))
96 (value-shape
97 ',(string->symbol (assoc-ref (assoc-ref exp "value") "shape"))))
98 (and (list? value)
99 (every (match-lambda
100 ((key . value)
101 (and (and=> (aws-name key)
102 (cut eq? <> key-shape))
103 (and=> (aws-name value)
104 (cut eq? <> value-shape))))
105 (_ #f))
106 value)))))
107 ;; Not a primitive type.
108 (unknown
109 (error (format #f "unknown primitive type: ~a~%" unknown)))))
110
111 (define (compile-member-args members required)
112 (append-map (match-lambda
113 ((name . spec)
114 (let ((slot-name (string->symbol name)))
115 (if (member name required)
116 `((,slot-name
117 (error (format #f "~a: required value missing."
118 ,name))))
119 (list (list slot-name ''__unspecified__))))))
120 members))
121
122 (define (compile-shape-stubs exp)
123 "Compile an AWS shape expression EXP to a stub."
124 (match exp
125 ((name . spec)
126 ;; Record shape spec for later type checking
127 (set! %shape-specs
128 (acons (string->symbol name)
129 (alist-delete "documentation" spec)
130 %shape-specs))
131 `(define ,(string->symbol name) #f))))
132
133 (define (compile-shape exp)
134 "Compile an AWS shape expression EXP."
135 (define required
136 (or (and=> (assoc-ref exp "required") vector->list)
137 '()))
138 (define members (assoc-ref exp "members"))
139 (define structure? (string=? (assoc-ref exp "type") "structure"))
140 (match exp
141 ((name . spec)
142 (let ((scm-name (string->symbol name)))
143 (if structure?
144 `(begin
145 (define ,scm-name
146 (lambda* (#:key ,@(compile-member-args members required))
147 ,(assoc-ref spec "documentation")
148 ;; Type checks
149 ,@(map (match-lambda
150 ((name . spec)
151 (let* ((key-name (string->symbol name))
152 (target-shape (string->symbol (assoc-ref spec "shape")))
153 (target-spec (assoc-ref %shape-specs target-shape)))
154 `(unless (eq? ,key-name '__unspecified__)
155 ,(if (and=> target-spec primitive?)
156 ;; Apply the primitive type
157 ;; check directly. This allows
158 ;; us to avoid unnecessary
159 ;; wrapping.
160 `(,(primitive-type-checker target-spec) ,key-name)
161 ;; Otherwise make sure the value has the correct type
162 `(ensure ,key-name
163 ',(string->symbol (assoc-ref spec "shape"))))))))
164 members)
165 (aws-structure
166 ',scm-name
167 (list ,@(map (match-lambda
168 ((name . spec)
169 `(aws-member #:name ',(string->symbol name)
170 #:shape ',(and=> (assoc-ref spec "shape") string->symbol)
171 #:location ,(assoc-ref spec "location")
172 #:location-name ,(assoc-ref spec "locationName")
173 #:documentation ,(assoc-ref spec "documentation")
174 #:value ,(string->symbol name))))
175 members)))))
176 (export ,scm-name))
177 `(begin
178 (define ,scm-name
179 (aws-shape #:aws-name ',scm-name
180 #:primitive?
181 ,(and (primitive?
182 (alist-delete "documentation" spec)) #t)
183 #:type-checker
184 ,(primitive-type-checker
185 (alist-delete "documentation" spec))
186 #:location
187 ',(and=> (assoc-ref spec "location") string->symbol)
188 #:location-name
189 ,(assoc-ref spec "locationName")
190 #:documentation
191 ,(assoc-ref spec "documentation")))
192 (export ,scm-name)))))))
193
194 (define (compile-operation exp)
195 "Compile an AWS operation expression EXP."
196 (match exp
197 ((name . spec)
198 `(begin
199 (define ,(string->symbol name)
200 (aws-operation
201 operation->request
202 #:name ,name
203 #:input-constructor
204 ,(and=> (assoc-ref spec "input")
205 (lambda (input)
206 (and=> (assoc-ref input "shape") string->symbol)))
207 #:input-type
208 ',(and=> (assoc-ref spec "input")
209 (lambda (input)
210 (and=> (assoc-ref input "shape") string->symbol)))
211 #:output-type
212 ',(and=> (assoc-ref spec "output")
213 (lambda (output)
214 (and=> (assoc-ref output "shape") string->symbol)))
215 #:http
216 ;; This includes things like "method", "requestUri", and "responseCode"
217 ',(assoc-ref spec "http")
218 #:documentation
219 ,(assoc-ref spec "documentation")))
220 (export ,(string->symbol name))))))
221
222 (define (compile-scheme exp env opts)
223 (and-let* ((meta (assoc-ref exp "metadata"))
224 (module-name (string->symbol (assoc-ref meta "uid"))))
225 (values `(begin
226 (define-module (aws api ,module-name)
227 #:use-module (aws base)
228 #:use-module (aws request)
229 #:use-module (ice-9 match)
230 #:use-module (srfi srfi-1)
231 #:use-module (srfi srfi-9)
232 #:use-module ((srfi srfi-19) #:select (date?))
233 #:use-module (srfi srfi-26)
234 #:use-module ((rnrs bytevectors) #:select (bytevector?)))
235 (define-public api-documentation
236 ,(assoc-ref exp "documentation"))
237 (define api-metadata
238 ',(map (lambda (key)
239 `(,(string->symbol key) . ,(assoc-ref meta key)))
240 (map car meta)))
241 (define operation->request
242 (make-operation->request api-metadata))
243 ;; Define all shapes first so that we don't have to do
244 ;; a topological sort. In the next step the shapes are
245 ;; redefined.
246 ,@(map compile-shape-stubs (assoc-ref exp "shapes"))
247 ,@(map compile-shape (assoc-ref exp "shapes"))
248 ,@(map compile-operation (assoc-ref exp "operations")))
249 env env)))
250
251 (define-language aws
252 #:title "AWS JSON specification language"
253 #:reader (lambda (port env)
254 (if (eof-object? (peek-char port))
255 (read-char port)
256 (read-json port)))
257 #:compilers `((scheme . ,compile-scheme))
258 #:printer write)