Initial commit.

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)