;;; 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))))))