summaryrefslogtreecommitdiff
path: root/aws/cloudformation
diff options
context:
space:
mode:
authorDavid Thompson <dthompson2@worcester.edu>2018-11-30 12:16:49 -0500
committerDavid Thompson <dthompson2@worcester.edu>2018-11-30 12:17:29 -0500
commiteea9dd7be5a5e2d79e2d42d15da5125e66946969 (patch)
treea8ceabfc23cdc1cae8593e28a18c61bd368040a5 /aws/cloudformation
parentd3f67ff773164522bd6eb4336a3ffa50a6af5543 (diff)
Refactor.
Diffstat (limited to 'aws/cloudformation')
-rw-r--r--aws/cloudformation/base.scm220
-rw-r--r--aws/cloudformation/utils.scm204
2 files changed, 222 insertions, 202 deletions
diff --git a/aws/cloudformation/base.scm b/aws/cloudformation/base.scm
new file mode 100644
index 0000000..76c073d
--- /dev/null
+++ b/aws/cloudformation/base.scm
@@ -0,0 +1,220 @@
+;;; guile-cloudformation --- Scheme DSL for CloudFormation templates
+;;; Copyright © 2018 David Thompson <davet@gnu.org>
+;;;
+;;; Guile-CloudFormation 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-CloudFormation 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 (aws cloudformation base)
+ #:use-module (aws cloudformation utils)
+ #:use-module (ice-9 match)
+ #:use-module (oop goops)
+ #:use-module (srfi srfi-1)
+ #:export (<cloudformation-property>
+ <cloudformation-object>
+ <cloudformation-attribute>
+ <cloudformation-resource>
+ <cloudformation-stack>
+ attributes
+ description
+ documentation-url
+ id
+ name
+ outputs
+ parameters
+ primitive-type
+ properties
+ required?
+ resource-name
+ resources
+ to-json
+ type-check
+ type-checker
+ update-type
+ valid?))
+
+(define-class <cloudformation-property> ()
+ (name #:getter name #:init-keyword #:name)
+ (type-checker #:getter type-checker #:init-keyword #:type-checker)
+ (required? #:getter required? #:init-keyword #:required?)
+ (update-type #:getter update-type #:init-keyword #:update-type)
+ (documentation-url #:getter documentation-url
+ #:init-keyword #:documentation-url))
+
+(define-method (type-check (procedure <procedure>) x)
+ (procedure x))
+
+(define-method (type-check (property <cloudformation-property>) x)
+ ((type-checker property) x))
+
+(define-class <cloudformation-class> (<class>)
+ (properties #:getter properties)
+ (cfn-name #:getter cfn-name)
+ (documentation-url #:getter documentation-url))
+
+(define-method (initialize (cfn-class <cloudformation-class>) args)
+ (define* (slot-cfn-property slot-name #:key cfn-property #:allow-other-keys)
+ (and cfn-property (cons slot-name cfn-property)))
+ (define* (init #:key cfn-name documentation-url slots #:allow-other-keys)
+ (slot-set! cfn-class 'cfn-name cfn-name)
+ (slot-set! cfn-class 'documentation-url documentation-url)
+ (slot-set! cfn-class
+ 'properties
+ (filter-map (lambda (slot-args)
+ (apply slot-cfn-property slot-args))
+ slots)))
+ (apply init args)
+ (next-method))
+
+(define-class <cloudformation-object> ()
+ #:metaclass <cloudformation-class>)
+
+(define-method (initialize (obj <cloudformation-object>) args)
+ (next-method)
+ ;; Ensure that all required properties have been specified, and that
+ ;; all specified properties pass the type checker.
+ (for-each (match-lambda
+ ((slot-name . prop)
+ (cond
+ ((and (required? prop) (not (slot-bound? obj slot-name)))
+ (error "required property not specified:" slot-name))
+ ((slot-bound? obj slot-name)
+ (let ((value (slot-ref obj slot-name)))
+ (unless (type-check prop value)
+ (error "wrong type for property:" slot-name value)))))))
+ (slot-ref (class-of obj) 'properties)))
+
+(define-method (cfn-name (obj <cloudformation-object>))
+ (cfn-name (class-of obj)))
+
+(define-method (properties (obj <cloudformation-object>))
+ (slot-ref (class-of obj) 'properties))
+
+(define-method (to-json/refs obj)
+ (to-json obj))
+
+(define-method (to-json (s <string>)) s)
+(define-method (to-json (b <boolean>)) b)
+(define-method (to-json (n <number>)) n)
+(define-method (to-json (p <pair>))
+ (if (pair? (car p))
+ `(@ ,@(map (match-lambda
+ ((k . v)
+ (cons k (to-json/refs v))))
+ p))
+ (cons (to-json/refs (car p)) (to-json (cdr p)))))
+(define-method (to-json (null <null>))
+ '())
+
+(define-method (to-json (obj <cloudformation-object>))
+ (cons '@
+ (filter-map (match-lambda
+ ((slot-name . property)
+ (and (slot-bound? obj slot-name)
+ (cons (name property)
+ (to-json/refs (slot-ref obj slot-name))))))
+ (properties obj))))
+
+(define-method (valid? (obj <cloudformation-object>))
+ (every (match-lambda
+ ((slot-name . property)
+ (cond
+ ((and (required? property) (not (slot-bound? obj slot-name)))
+ #f)
+ ((not (or (required? property) (slot-bound? obj slot-name)))
+ #t)
+ (else
+ (type-check property (slot-ref obj slot-name))))))
+ (slot-ref (class-of obj) 'properties)))
+
+(define-class <cloudformation-attribute> ()
+ (name #:getter name #:init-keyword #:name)
+ (primitive-type #:getter primitive-type #:init-keyword #:primitive-type))
+
+(define-class <cloudformation-resource-class> (<cloudformation-class>)
+ (resource-name-prefix #:getter resource-name-prefix)
+ (attributes #:getter attributes))
+
+(define-method (initialize (resource-class <cloudformation-resource-class>) args)
+ (define* (init #:key attributes cfn-name #:allow-other-keys)
+ (when cfn-name
+ (slot-set! resource-class 'resource-name-prefix
+ (string-concatenate
+ (drop (delete "" (string-split cfn-name #\:)) 1))))
+ (slot-set! resource-class 'attributes attributes))
+ (apply init args)
+ (next-method))
+
+(define-class <cloudformation-resource> (<cloudformation-object>)
+ (id #:getter id #:init-keyword #:id)
+ (cfn-id #:getter cfn-id)
+ #:metaclass <cloudformation-resource-class>)
+
+(define-method (initialize (resource <cloudformation-resource>) args)
+ (next-method)
+ (unless (slot-bound? resource 'id)
+ (error "no id specified for resource:" resource))
+ (slot-set! resource 'cfn-id (id->cfn-id (id resource))))
+
+(define-method (type-check (proc <procedure>)
+ (resource <cloudformation-resource>))
+ (type-check proc "arn:dummy"))
+
+(define-method (to-json/refs (resource <cloudformation-resource>))
+ `(@ ("Ref" . ,(cfn-id resource))))
+
+(define-method (to-json (resource <cloudformation-resource>))
+ `(@ ("Type" . ,(cfn-name resource))
+ ("Properties" . ,(next-method))))
+
+(define-class <cloudformation-stack> ()
+ (description #:getter description #:init-keyword #:description #:init-form "")
+ (parameters #:getter parameters #:init-keyword #:parameters)
+ (resources #:getter resources #:init-keyword #:resources)
+ (outputs #:getter outputs #:init-keyword #:outputs))
+
+(define-method (transitive-resources (stack <cloudformation-stack>))
+ (define (scan-object obj)
+ (cond
+ ((is-a? obj <pair>)
+ (match obj
+ ((first rest ...)
+ (concatenate (cons (scan-object first)
+ (scan-object rest))))
+ ((key . value)
+ (scan-object value))))
+ ((is-a? obj <cloudformation-resource>)
+ (list obj))
+ ((is-a? obj <cloudformation-object>)
+ (scan-properties obj))
+ (else
+ '())))
+ (define (scan-properties obj)
+ (append-map (match-lambda
+ ((slot-name . prop)
+ (let ((value (and (slot-bound? obj slot-name)
+ (slot-ref obj slot-name))))
+ (scan-object value))))
+ (properties obj)))
+ (append-map (lambda (resource)
+ (cons resource (scan-properties resource)))
+ (resources stack)))
+
+(define-method (to-json (stack <cloudformation-stack>))
+ `(@ ("AWSTemplateFormatVersion" . "2010-09-09")
+ ("Description" . ,(description stack))
+ ("Resources" .
+ (@ ,@(map (lambda (resource)
+ (cons (cfn-id resource)
+ (to-json resource)))
+ (transitive-resources stack))))))
diff --git a/aws/cloudformation/utils.scm b/aws/cloudformation/utils.scm
index 8aea303..2bb32d8 100644
--- a/aws/cloudformation/utils.scm
+++ b/aws/cloudformation/utils.scm
@@ -18,33 +18,9 @@
(define-module (aws cloudformation utils)
#:use-module (aws cloudformation utils base32)
#:use-module (aws cloudformation utils sha-1)
- #:use-module (ice-9 match)
- #:use-module (oop goops)
#:use-module (rnrs bytevectors)
- #:use-module (srfi srfi-1)
- #:export (<cloudformation-property>
- <cloudformation-object>
- <cloudformation-attribute>
- <cloudformation-resource>
- <cloudformation-stack>
- attributes
- aws-string->symbol
- description
- documentation-url
- id
- name
- outputs
- parameters
- primitive-type
- properties
- required?
- resource-name
- resources
- to-json
- type-check
- type-checker
- update-type
- valid?))
+ #:export (aws-string->symbol
+ id->cfn-id))
(define (aws-string->symbol str)
;; Drop the "AWS::" that's at the beginning of *almost* everything.
@@ -96,123 +72,6 @@
(else
(cons (string-ref str i) (loop (1+ i) #f #f))))))))
-(define-class <cloudformation-property> ()
- (name #:getter name #:init-keyword #:name)
- (type-checker #:getter type-checker #:init-keyword #:type-checker)
- (required? #:getter required? #:init-keyword #:required?)
- (update-type #:getter update-type #:init-keyword #:update-type)
- (documentation-url #:getter documentation-url
- #:init-keyword #:documentation-url))
-
-(define-method (type-check (procedure <procedure>) x)
- (procedure x))
-
-(define-method (type-check (property <cloudformation-property>) x)
- ((type-checker property) x))
-
-(define-class <cloudformation-class> (<class>)
- (properties #:getter properties)
- (cfn-name #:getter cfn-name)
- (documentation-url #:getter documentation-url))
-
-(define-method (initialize (cfn-class <cloudformation-class>) args)
- (define* (slot-cfn-property slot-name #:key cfn-property #:allow-other-keys)
- (and cfn-property (cons slot-name cfn-property)))
- (define* (init #:key cfn-name documentation-url slots #:allow-other-keys)
- (slot-set! cfn-class 'cfn-name cfn-name)
- (slot-set! cfn-class 'documentation-url documentation-url)
- (slot-set! cfn-class
- 'properties
- (filter-map (lambda (slot-args)
- (apply slot-cfn-property slot-args))
- slots)))
- (apply init args)
- (next-method))
-
-(define-class <cloudformation-object> ()
- #:metaclass <cloudformation-class>)
-
-(define-method (initialize (obj <cloudformation-object>) args)
- (next-method)
- ;; Ensure that all required properties have been specified, and that
- ;; all specified properties pass the type checker.
- (for-each (match-lambda
- ((slot-name . prop)
- (cond
- ((and (required? prop) (not (slot-bound? obj slot-name)))
- (error "required property not specified:" slot-name))
- ((slot-bound? obj slot-name)
- (let ((value (slot-ref obj slot-name)))
- (unless (type-check prop value)
- (error "wrong type for property:" slot-name value)))))))
- (slot-ref (class-of obj) 'properties)))
-
-(define-method (cfn-name (obj <cloudformation-object>))
- (cfn-name (class-of obj)))
-
-(define-method (properties (obj <cloudformation-object>))
- (slot-ref (class-of obj) 'properties))
-
-(define-method (to-json/refs obj)
- (to-json obj))
-
-(define-method (to-json (s <string>)) s)
-(define-method (to-json (b <boolean>)) b)
-(define-method (to-json (n <number>)) n)
-(define-method (to-json (p <pair>))
- (if (pair? (car p))
- `(@ ,@(map (match-lambda
- ((k . v)
- (cons k (to-json/refs v))))
- p))
- (cons (to-json/refs (car p)) (to-json (cdr p)))))
-(define-method (to-json (null <null>))
- '())
-
-(define-method (to-json (obj <cloudformation-object>))
- (cons '@
- (filter-map (match-lambda
- ((slot-name . property)
- (and (slot-bound? obj slot-name)
- (cons (name property)
- (to-json/refs (slot-ref obj slot-name))))))
- (properties obj))))
-
-(define-method (valid? (obj <cloudformation-object>))
- (every (match-lambda
- ((slot-name . property)
- (cond
- ((and (required? property) (not (slot-bound? obj slot-name)))
- #f)
- ((not (or (required? property) (slot-bound? obj slot-name)))
- #t)
- (else
- (type-check property (slot-ref obj slot-name))))))
- (slot-ref (class-of obj) 'properties)))
-
-(define-class <cloudformation-attribute> ()
- (name #:getter name #:init-keyword #:name)
- (primitive-type #:getter primitive-type #:init-keyword #:primitive-type))
-
-(define-class <cloudformation-resource-class> (<cloudformation-class>)
- (resource-name-prefix #:getter resource-name-prefix)
- (attributes #:getter attributes))
-
-(define-method (initialize (resource-class <cloudformation-resource-class>) args)
- (define* (init #:key attributes cfn-name #:allow-other-keys)
- (when cfn-name
- (slot-set! resource-class 'resource-name-prefix
- (string-join (drop (delete "" (string-split cfn-name #\:)) 1)
- "")))
- (slot-set! resource-class 'attributes attributes))
- (apply init args)
- (next-method))
-
-(define-class <cloudformation-resource> (<cloudformation-object>)
- (id #:getter id #:init-keyword #:id)
- (cfn-id #:getter cfn-id)
- #:metaclass <cloudformation-resource-class>)
-
(define char-set:alphanumeric
(char-set-intersection char-set:ascii char-set:letter+digit))
@@ -233,62 +92,3 @@
(sha-1
(string->utf8
(symbol->string sym)))))))
-
-(define-method (initialize (resource <cloudformation-resource>) args)
- (next-method)
- (unless (slot-bound? resource 'id)
- (error "no id specified for resource:" resource))
- (slot-set! resource 'cfn-id (id->cfn-id (id resource))))
-
-(define-method (type-check (proc <procedure>)
- (resource <cloudformation-resource>))
- (type-check proc "arn:dummy"))
-
-(define-method (to-json/refs (resource <cloudformation-resource>))
- `(@ ("Ref" . ,(cfn-id resource))))
-
-(define-method (to-json (resource <cloudformation-resource>))
- `(@ ("Type" . ,(cfn-name resource))
- ("Properties" . ,(next-method))))
-
-(define-class <cloudformation-stack> ()
- (description #:getter description #:init-keyword #:description #:init-form "")
- (parameters #:getter parameters #:init-keyword #:parameters)
- (resources #:getter resources #:init-keyword #:resources)
- (outputs #:getter outputs #:init-keyword #:outputs))
-
-(define-method (transitive-resources (stack <cloudformation-stack>))
- (define (scan-object obj)
- (cond
- ((is-a? obj <pair>)
- (match obj
- ((first rest ...)
- (concatenate (cons (scan-object first)
- (scan-object rest))))
- ((key . value)
- (scan-object value))))
- ((is-a? obj <cloudformation-resource>)
- (list obj))
- ((is-a? obj <cloudformation-object>)
- (scan-properties obj))
- (else
- '())))
- (define (scan-properties obj)
- (append-map (match-lambda
- ((slot-name . prop)
- (let ((value (and (slot-bound? obj slot-name)
- (slot-ref obj slot-name))))
- (scan-object value))))
- (properties obj)))
- (append-map (lambda (resource)
- (cons resource (scan-properties resource)))
- (resources stack)))
-
-(define-method (to-json (stack <cloudformation-stack>))
- `(@ ("AWSTemplateFormatVersion" . "2010-09-09")
- ("Description" . ,(description stack))
- ("Resources" .
- (@ ,@(map (lambda (resource)
- (cons (cfn-id resource)
- (to-json resource)))
- (transitive-resources stack))))))