diff options
Diffstat (limited to 'language')
| -rw-r--r-- | language/aws/spec.scm | 218 |
1 files changed, 218 insertions, 0 deletions
diff --git a/language/aws/spec.scm b/language/aws/spec.scm new file mode 100644 index 0000000..5498c11 --- /dev/null +++ b/language/aws/spec.scm @@ -0,0 +1,218 @@ +;;; guile-aws --- Scheme DSL for the AWS APIs +;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net> +;;; +;;; Guile-AWS is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published +;;; by the Free Software Foundation, either version 3 of the License, +;;; or (at your option) any later version. +;;; +;;; Guile-AWS is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (language aws spec) + #:use-module (aws base) + #:use-module (aws utils json) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-2) + #:use-module (system base language) + #:export (aws)) + +(define (primitive? exp) + (member (assoc-ref exp "type") + '("string" + "blob" + "boolean" + "timestamp" + "integer" "long" + "double" "float" + "list"))) + +(define (primitive-type-checker exp) + "Return an S-expression representation of a type checking procedure +for a shape expression EXP with a primitive data type. Throw an error +if this is not a primitive data type." + (match (assoc-ref exp "type") + ("string" + (let ((enum (and=> (assoc-ref exp "enum") + vector->list))) + (if enum + `(lambda (value) + (member value ',enum)) + 'string?))) + ("blob" 'bytevector?) + ("boolean" 'boolean?) + ("timestamp" 'date?) + ((or "integer" "long") + `(lambda (value) + (let ((min ,(assoc-ref exp "min")) + (max ,(assoc-ref exp "max"))) + (and (integer? value) + (if min (>= value min) #t) + (if max (<= value max) #t))))) + ((or "double" "float") 'real?) + ("list" + (let ((member-spec (assoc-ref exp "member"))) + (if member-spec + `(lambda (value) + (let ((shape ',(string->symbol (assoc-ref member-spec "shape")))) + (and (list? value) + (every (lambda (item) + (and=> (aws-name item) + (cut eq? <> shape))) + value)))) + 'list?))) + ("map" + `(lambda (value) + (let ((key-shape + ',(string->symbol (assoc-ref (assoc-ref exp "key") "shape"))) + (value-shape + ',(string->symbol (assoc-ref (assoc-ref exp "value") "shape")))) + (and (list? value) + (every (match-lambda + ((key . value) + (and (and=> (aws-name key) + (cut eq? <> key-shape)) + (and=> (aws-name value) + (cut eq? <> value-shape)))) + (_ #f)) + value))))) + ;; Not a primitive type. + (unknown + (error (format #f "unknown primitive type: ~a~%" unknown))))) + +(define (compile-member-args members required) + (append-map (match-lambda + ((name . spec) + (let ((slot-name (string->symbol name))) + (if (member name required) + `((,slot-name + (error (format #f "~a: required value missing." + ,name)))) + (list (list slot-name ''__unspecified__)))))) + members)) + +(define (compile-shape-stubs exp) + "Compile an AWS shape expression EXP to a stub." + (match exp + ((name . _) + `(define ,(string->symbol name) #f)))) + +(define (compile-shape exp) + "Compile an AWS shape expression EXP." + (define required + (or (and=> (assoc-ref exp "required") vector->list) + '())) + (define members (assoc-ref exp "members")) + (define structure? (string=? (assoc-ref exp "type") "structure")) + (match exp + ((name . spec) + (let ((scm-name (string->symbol name))) + (if structure? + `(begin + (define ,scm-name + (lambda* (#:key ,@(compile-member-args members required)) + ,(assoc-ref spec "documentation") + ;; Type checks + ,@(map (match-lambda + ((name . spec) + (let ((key-name (string->symbol name))) + `(unless (eq? ,key-name '__unspecified__) + (ensure ,key-name + ',(string->symbol (assoc-ref spec "shape"))))))) + members) + (aws-structure + ',scm-name + (list ,@(map (match-lambda + ((name . spec) + `(aws-member #:name ',(string->symbol name) + #:shape ',(and=> (assoc-ref spec "shape") string->symbol) + #:location ,(assoc-ref spec "location") + #:location-name ,(assoc-ref spec "locationName") + #:documentation ,(assoc-ref spec "documentation") + #:value ,(string->symbol name)))) + members))))) + (export ,scm-name)) + `(begin + (define ,scm-name + (aws-shape #:aws-name ',scm-name + #:primitive? + ,(and (primitive? + (alist-delete "documentation" spec)) #t) + #:type-checker + ,(primitive-type-checker + (alist-delete "documentation" spec)) + #:location + ',(and=> (assoc-ref spec "location") string->symbol) + #:location-name + ,(assoc-ref spec "locationName") + #:documentation + ,(assoc-ref spec "documentation"))) + (export ,scm-name))))))) + +(define (compile-operation exp) + "Compile an AWS operation expression EXP." + (match exp + ((name . spec) + `(begin + (define ,(string->symbol name) + (aws-operation + operation->request + #:name ,name + #:input-type + ',(and=> (assoc-ref spec "input") + (lambda (input) + (and=> (assoc-ref input "shape") string->symbol))) + #:output-type + ',(and=> (assoc-ref spec "output") + (lambda (output) + (and=> (assoc-ref output "shape") string->symbol))) + #:http + ',(assoc-ref spec "http") + #:documentation + ,(assoc-ref spec "documentation"))) + (export ,(string->symbol name)))))) + +(define (compile-scheme exp env opts) + (and-let* ((meta (assoc-ref exp "metadata")) + (module-name (string->symbol (assoc-ref meta "uid")))) + (values `(begin + (define-module (aws api ,module-name) + #:use-module (aws base) + #:use-module (aws request) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module ((srfi srfi-19) #:select (date?)) + #:use-module (srfi srfi-26) + #:use-module ((rnrs bytevectors) #:select (bytevector?))) + (define-public api-documentation + ,(assoc-ref exp "documentation")) + (define api-metadata + ',(map (lambda (key) + `(,(string->symbol key) . ,(assoc-ref meta key))) + (map car meta))) + (define operation->request + (make-operation->request api-metadata)) + ;; Define all shapes first so that we don't have to do + ;; a topological sort. In the next step the shapes are + ;; redefined. + ,@(map compile-shape-stubs (assoc-ref exp "shapes")) + ,@(map compile-shape (assoc-ref exp "shapes")) + ,@(map compile-operation (assoc-ref exp "operations"))) + env env))) + +(define-language aws + #:title "AWS JSON specification language" + #:reader (lambda (port env) + (if (eof-object? (peek-char port)) + (read-char port) + (read-json port))) + #:compilers `((scheme . ,compile-scheme)) + #:printer write) |