;;; guile-cloudformation --- Scheme DSL for CloudFormation templates
;;; Copyright © 2018 David Thompson <davet@gnu.org>
;;; Copyright © 2012, 2015, 2017 Ludovic Courtès <ludo@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 base32)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-60)
  #:export (base32-encode))

;; Credit to Ludovic Courtes
(define bytevector-quintet-ref
  (let* ((ref  bytevector-u8-ref)
         (ref+ (lambda (bv offset)
                 (let ((o (+ 1 offset)))
                   (if (>= o (bytevector-length bv))
                       0
                       (bytevector-u8-ref bv o)))))
         (ref0 (lambda (bv offset)
                 (bit-field (ref bv offset) 3 8)))
         (ref1 (lambda (bv offset)
                 (logior (ash (bit-field (ref bv offset) 0 3) 2)
                         (bit-field (ref+ bv offset) 6 8))))
         (ref2 (lambda (bv offset)
                 (bit-field (ref bv offset) 1 6)))
         (ref3 (lambda (bv offset)
                 (logior (ash (bit-field (ref bv offset) 0 1) 4)
                         (bit-field (ref+ bv offset) 4 8))))
         (ref4 (lambda (bv offset)
                 (logior (ash (bit-field (ref bv offset) 0 4) 1)
                         (bit-field (ref+ bv offset) 7 8))))
         (ref5 (lambda (bv offset)
                 (bit-field (ref bv offset) 2 7)))
         (ref6 (lambda (bv offset)
                 (logior (ash (bit-field (ref bv offset) 0 2) 3)
                         (bit-field (ref+ bv offset) 5 8))))
         (ref7 (lambda (bv offset)
                 (bit-field (ref bv offset) 0 5)))
         (refs (vector ref0 ref1 ref2 ref3 ref4 ref5 ref6 ref7)))
    (lambda (bv index)
      "Return the INDEXth quintet of BV."
      (let ((p (vector-ref refs (modulo index 8))))
        (p bv (quotient (* index 5) 8))))))

(define (base32-encode bv)
  ;; We are assuming that the bytevector length is divisible by 5,
  ;; because that is the case for SHA-1 hashes. A general-purpose
  ;; base32 encoder would need to pad the bytevector when this is not
  ;; the case.
  (let* ((alphabet "0123456789ABCDEFGHJKMNPQRSTVWXYZ")
         (n (/ (* (bytevector-length bv) 8) 5))
         (s (make-string n)))
    (let loop ((i 0))
      (when (< i n)
        (let ((x (bytevector-quintet-ref bv i)))
          (string-set! s i (string-ref alphabet x))
          (loop (+ i 1)))))
    s))