From eea9dd7be5a5e2d79e2d42d15da5125e66946969 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Fri, 30 Nov 2018 12:16:49 -0500 Subject: Refactor. --- aws/cloudformation.scm | 25 +++++ aws/cloudformation/base.scm | 220 +++++++++++++++++++++++++++++++++++++++++++ aws/cloudformation/utils.scm | 204 +-------------------------------------- 3 files changed, 247 insertions(+), 202 deletions(-) create mode 100644 aws/cloudformation.scm create mode 100644 aws/cloudformation/base.scm (limited to 'aws') diff --git a/aws/cloudformation.scm b/aws/cloudformation.scm new file mode 100644 index 0000000..28780a8 --- /dev/null +++ b/aws/cloudformation.scm @@ -0,0 +1,25 @@ +;;; guile-cloudformation --- Scheme DSL for CloudFormation templates +;;; Copyright © 2018 David Thompson +;;; +;;; 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 +;;; . + +(define-module (aws cloudformation)) + +;; Export public bindings from other modules for convenience. +(for-each (let ((i (module-public-interface (current-module)))) + (lambda (m) + (module-use! i (resolve-interface + `(aws cloudformation ,m))))) + '(base universal)) 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 +;;; +;;; 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 +;;; . + +(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 ( + + + + + 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 () + (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 ) x) + (procedure x)) + +(define-method (type-check (property ) x) + ((type-checker property) x)) + +(define-class () + (properties #:getter properties) + (cfn-name #:getter cfn-name) + (documentation-url #:getter documentation-url)) + +(define-method (initialize (cfn-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 () + #:metaclass ) + +(define-method (initialize (obj ) 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 )) + (cfn-name (class-of obj))) + +(define-method (properties (obj )) + (slot-ref (class-of obj) 'properties)) + +(define-method (to-json/refs obj) + (to-json obj)) + +(define-method (to-json (s )) s) +(define-method (to-json (b )) b) +(define-method (to-json (n )) n) +(define-method (to-json (p )) + (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 )) + '()) + +(define-method (to-json (obj )) + (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 )) + (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 () + (name #:getter name #:init-keyword #:name) + (primitive-type #:getter primitive-type #:init-keyword #:primitive-type)) + +(define-class () + (resource-name-prefix #:getter resource-name-prefix) + (attributes #:getter attributes)) + +(define-method (initialize (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 () + (id #:getter id #:init-keyword #:id) + (cfn-id #:getter cfn-id) + #:metaclass ) + +(define-method (initialize (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 ) + (resource )) + (type-check proc "arn:dummy")) + +(define-method (to-json/refs (resource )) + `(@ ("Ref" . ,(cfn-id resource)))) + +(define-method (to-json (resource )) + `(@ ("Type" . ,(cfn-name resource)) + ("Properties" . ,(next-method)))) + +(define-class () + (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 )) + (define (scan-object obj) + (cond + ((is-a? obj ) + (match obj + ((first rest ...) + (concatenate (cons (scan-object first) + (scan-object rest)))) + ((key . value) + (scan-object value)))) + ((is-a? obj ) + (list obj)) + ((is-a? obj ) + (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 )) + `(@ ("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 ( - - - - - 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 () - (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 ) x) - (procedure x)) - -(define-method (type-check (property ) x) - ((type-checker property) x)) - -(define-class () - (properties #:getter properties) - (cfn-name #:getter cfn-name) - (documentation-url #:getter documentation-url)) - -(define-method (initialize (cfn-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 () - #:metaclass ) - -(define-method (initialize (obj ) 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 )) - (cfn-name (class-of obj))) - -(define-method (properties (obj )) - (slot-ref (class-of obj) 'properties)) - -(define-method (to-json/refs obj) - (to-json obj)) - -(define-method (to-json (s )) s) -(define-method (to-json (b )) b) -(define-method (to-json (n )) n) -(define-method (to-json (p )) - (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 )) - '()) - -(define-method (to-json (obj )) - (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 )) - (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 () - (name #:getter name #:init-keyword #:name) - (primitive-type #:getter primitive-type #:init-keyword #:primitive-type)) - -(define-class () - (resource-name-prefix #:getter resource-name-prefix) - (attributes #:getter attributes)) - -(define-method (initialize (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 () - (id #:getter id #:init-keyword #:id) - (cfn-id #:getter cfn-id) - #:metaclass ) - (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 ) 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 ) - (resource )) - (type-check proc "arn:dummy")) - -(define-method (to-json/refs (resource )) - `(@ ("Ref" . ,(cfn-id resource)))) - -(define-method (to-json (resource )) - `(@ ("Type" . ,(cfn-name resource)) - ("Properties" . ,(next-method)))) - -(define-class () - (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 )) - (define (scan-object obj) - (cond - ((is-a? obj ) - (match obj - ((first rest ...) - (concatenate (cons (scan-object first) - (scan-object rest)))) - ((key . value) - (scan-object value)))) - ((is-a? obj ) - (list obj)) - ((is-a? obj ) - (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 )) - `(@ ("AWSTemplateFormatVersion" . "2010-09-09") - ("Description" . ,(description stack)) - ("Resources" . - (@ ,@(map (lambda (resource) - (cons (cfn-id resource) - (to-json resource))) - (transitive-resources stack)))))) -- cgit v1.2.3