Initial commit.
[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 (primitive? exp)
28 (member (assoc-ref exp "type")
29 '("string"
30 "blob"
31 "boolean"
32 "timestamp"
33 "integer" "long"
34 "double" "float"
35 "list")))
36
37 (define (primitive-type-checker exp)
38 "Return an S-expression representation of a type checking procedure
39 for a shape expression EXP with a primitive data type. Throw an error
40 if this is not a primitive data type."
41 (match (assoc-ref exp "type")
42 ("string"
43 (let ((enum (and=> (assoc-ref exp "enum")
44 vector->list)))
45 (if enum
46 `(lambda (value)
47 (member value ',enum))
48 'string?)))
49 ("blob" 'bytevector?)
50 ("boolean" 'boolean?)
51 ("timestamp" 'date?)
52 ((or "integer" "long")
53 `(lambda (value)
54 (let ((min ,(assoc-ref exp "min"))
55 (max ,(assoc-ref exp "max")))
56 (and (integer? value)
57 (if min (>= value min) #t)
58 (if max (<= value max) #t)))))
59 ((or "double" "float") 'real?)
60 ("list"
61 (let ((member-spec (assoc-ref exp "member")))
62 (if member-spec
63 `(lambda (value)
64 (let ((shape ',(string->symbol (assoc-ref member-spec "shape"))))
65 (and (list? value)
66 (every (lambda (item)
67 (and=> (aws-name item)
68 (cut eq? <> shape)))
69 value))))
70 'list?)))
71 ("map"
72 `(lambda (value)
73 (let ((key-shape
74 ',(string->symbol (assoc-ref (assoc-ref exp "key") "shape")))
75 (value-shape
76 ',(string->symbol (assoc-ref (assoc-ref exp "value") "shape"))))
77 (and (list? value)
78 (every (match-lambda
79 ((key . value)
80 (and (and=> (aws-name key)
81 (cut eq? <> key-shape))
82 (and=> (aws-name value)
83 (cut eq? <> value-shape))))
84 (_ #f))
85 value)))))
86 ;; Not a primitive type.
87 (unknown
88 (error (format #f "unknown primitive type: ~a~%" unknown)))))
89
90 (define (compile-member-args members required)
91 (append-map (match-lambda
92 ((name . spec)
93 (let ((slot-name (string->symbol name)))
94 (if (member name required)
95 `((,slot-name
96 (error (format #f "~a: required value missing."
97 ,name))))
98 (list (list slot-name ''__unspecified__))))))
99 members))
100
101 (define (compile-shape-stubs exp)
102 "Compile an AWS shape expression EXP to a stub."
103 (match exp
104 ((name . _)
105 `(define ,(string->symbol name) #f))))
106
107 (define (compile-shape exp)
108 "Compile an AWS shape expression EXP."
109 (define required
110 (or (and=> (assoc-ref exp "required") vector->list)
111 '()))
112 (define members (assoc-ref exp "members"))
113 (define structure? (string=? (assoc-ref exp "type") "structure"))
114 (match exp
115 ((name . spec)
116 (let ((scm-name (string->symbol name)))
117 (if structure?
118 `(begin
119 (define ,scm-name
120 (lambda* (#:key ,@(compile-member-args members required))
121 ,(assoc-ref spec "documentation")
122 ;; Type checks
123 ,@(map (match-lambda
124 ((name . spec)
125 (let ((key-name (string->symbol name)))
126 `(unless (eq? ,key-name '__unspecified__)
127 (ensure ,key-name
128 ',(string->symbol (assoc-ref spec "shape")))))))
129 members)
130 (aws-structure
131 ',scm-name
132 (list ,@(map (match-lambda
133 ((name . spec)
134 `(aws-member #:name ',(string->symbol name)
135 #:shape ',(and=> (assoc-ref spec "shape") string->symbol)
136 #:location ,(assoc-ref spec "location")
137 #:location-name ,(assoc-ref spec "locationName")
138 #:documentation ,(assoc-ref spec "documentation")
139 #:value ,(string->symbol name))))
140 members)))))
141 (export ,scm-name))
142 `(begin
143 (define ,scm-name
144 (aws-shape #:aws-name ',scm-name
145 #:primitive?
146 ,(and (primitive?
147 (alist-delete "documentation" spec)) #t)
148 #:type-checker
149 ,(primitive-type-checker
150 (alist-delete "documentation" spec))
151 #:location
152 ',(and=> (assoc-ref spec "location") string->symbol)
153 #:location-name
154 ,(assoc-ref spec "locationName")
155 #:documentation
156 ,(assoc-ref spec "documentation")))
157 (export ,scm-name)))))))
158
159 (define (compile-operation exp)
160 "Compile an AWS operation expression EXP."
161 (match exp
162 ((name . spec)
163 `(begin
164 (define ,(string->symbol name)
165 (aws-operation
166 operation->request
167 #:name ,name
168 #:input-type
169 ',(and=> (assoc-ref spec "input")
170 (lambda (input)
171 (and=> (assoc-ref input "shape") string->symbol)))
172 #:output-type
173 ',(and=> (assoc-ref spec "output")
174 (lambda (output)
175 (and=> (assoc-ref output "shape") string->symbol)))
176 #:http
177 ',(assoc-ref spec "http")
178 #:documentation
179 ,(assoc-ref spec "documentation")))
180 (export ,(string->symbol name))))))
181
182 (define (compile-scheme exp env opts)
183 (and-let* ((meta (assoc-ref exp "metadata"))
184 (module-name (string->symbol (assoc-ref meta "uid"))))
185 (values `(begin
186 (define-module (aws api ,module-name)
187 #:use-module (aws base)
188 #:use-module (aws request)
189 #:use-module (ice-9 match)
190 #:use-module (srfi srfi-1)
191 #:use-module (srfi srfi-9)
192 #:use-module ((srfi srfi-19) #:select (date?))
193 #:use-module (srfi srfi-26)
194 #:use-module ((rnrs bytevectors) #:select (bytevector?)))
195 (define-public api-documentation
196 ,(assoc-ref exp "documentation"))
197 (define api-metadata
198 ',(map (lambda (key)
199 `(,(string->symbol key) . ,(assoc-ref meta key)))
200 (map car meta)))
201 (define operation->request
202 (make-operation->request api-metadata))
203 ;; Define all shapes first so that we don't have to do
204 ;; a topological sort. In the next step the shapes are
205 ;; redefined.
206 ,@(map compile-shape-stubs (assoc-ref exp "shapes"))
207 ,@(map compile-shape (assoc-ref exp "shapes"))
208 ,@(map compile-operation (assoc-ref exp "operations")))
209 env env)))
210
211 (define-language aws
212 #:title "AWS JSON specification language"
213 #:reader (lambda (port env)
214 (if (eof-object? (peek-char port))
215 (read-char port)
216 (read-json port)))
217 #:compilers `((scheme . ,compile-scheme))
218 #:printer write)