;;; 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 utils)
  #:use-module (aws cloudformation utils base32)
  #:use-module (aws cloudformation utils sha-1)
  #:use-module (rnrs bytevectors)
  #:export (aws-string->symbol
            id->cfn-id))

(define (aws-string->symbol str)
  ;; Drop the "AWS::" that's at the beginning of *almost* everything.
  (let ((str (if (string-prefix? "AWS::" str)
                 (string-drop str 5)
                 str)))
    (list->symbol
     (let loop ((i 0)
                (same-word? #t)
                (slash-delimiter? #f))
       (cond
        ((= i (string-length str)) ; end of string
         '())
        ;; "IoT" violates all the rules. grrrr
        ((and (< (+ i 3) (string-length str))
              (eqv? (string-ref str i) #\I)
              (eqv? (string-ref str (+ i 1)) #\o)
              (eqv? (string-ref str (+ i 2)) #\T))
         (cons* #\i #\o #\t (loop (+ i 3) #f #f)))
        ;; Replace "." with "/"
        ((eqv? (string-ref str i) #\.)
         (cons #\/ (loop (1+ i) #f #t)))
        ;; Get rid of "::"
        ((and (eqv? (string-ref str i) #\:)
              (eqv? (string-ref str (1+ i)) #\:))
         (loop (+ i 2) #f #f))
        ((char-upper-case? (string-ref str i)) ; detect camel casing
         (cond
          ;; If we've had a string of uppercase characters and the
          ;; next character is lowercase, we're actually at the
          ;; beginning of a new word.  For example, when we reach the
          ;; "I" in "DBInstance" we need to treat it as the beginning
          ;; of a new word.
          ((and same-word?
                (< (1+ i) (string-length str))
                (char-lower-case? (string-ref str (1+ i))))
           (loop i #f #f))
          ;; Consecutive uppercase characters are part of the same word.
          (same-word?
           (cons (char-downcase (string-ref str i)) (loop (1+ i) #t #f)))
          ;; Encountering an uppercase character after a series of
          ;; non-uppercase characters means that we are at the
          ;; beginning of a new word.
          (else
           (if (or (zero? i) slash-delimiter?)
               (cons (char-downcase (string-ref str i)) (loop (1+ i) #t #f))
               (cons* #\- (char-downcase (string-ref str i))
                      (loop (1+ i) #t #f))))))
        (else
         (cons (string-ref str i) (loop (1+ i) #f #f))))))))

(define char-set:alphanumeric
  (char-set-intersection char-set:ascii char-set:letter+digit))

(define (alphanumize s)
  (string-filter char-set:alphanumeric s))

(define (id->cfn-id sym)
  (string-append (let ((camelized
                        (string-concatenate
                         (map (lambda (s)
                                (string-capitalize (alphanumize s)))
                              (string-split (symbol->string sym) #\-)))))
                   (if (> (string-length camelized) 223)
                       (substring camelized 223)
                       camelized))
                 (base32-encode
                  (sha-1->bytevector
                   (sha-1
                    (string->utf8
                     (symbol->string sym)))))))