;; Issues
;;
;; - requires a "body" to consist of lines w/ leading whitespace! this is too
;; restrictive.

(import scheme
  (chicken base) ;alist-update, alist-ref
  (chicken type)
  (chicken pathname)
  (only (chicken io) read-line)
  (only (chicken file) directory)
  (only (chicken string) string-intersperse)
  (only (srfi 4) u8vector-length read-u8vector)
  (only (srfi 1) first filter reverse!)
  (only srfi-13
    string-null? string-downcase
    string-trim string-trim-right string-trim-both
    string-suffix?)
  (only message-digest-srfi-4 message-digest-u8vector)
  sha2
  test)

;miscmacros
(define-syntax while
  (syntax-rules ()
    ((while test body ...)
     (let loop ()
       (if test
           (begin
             body ...
             (loop)))))))

(test-begin "Sha2 Testvectors")

(define *peek-line)
(define *read-line)
(let ((+buf+ (the (or false eof string) #f)))
  (set! *peek-line
    (lambda (#!optional (port (current-input-port)))
      (or +buf+
          (begin
            (set! +buf+ (read-line port))
            +buf+))))
  (set! *read-line
    (lambda (#!optional (port (current-input-port)))
      (if +buf+
        (let ((lin +buf+))
          (set! +buf+ #f)
          lin)
        (read-line port)))) )

(define-constant MAXIMUM-DATA-LENGTH 1000000)

;pathname -> u8vector or #f
(define (read-vector-data pn)
  (let ((dat (call-with-input-file pn (cut read-u8vector MAXIMUM-DATA-LENGTH <>) #:binary)))
    (if (eof-object? dat) #u8() dat) ) )

;string -> boolean
(define (leading-whitespace? lin)
  (< (string-length (string-trim lin)) (string-length lin)) )

;input-port -> string or #f
(define (read-body port)
  (let loop ((ls '()))
    (let ((lin (*peek-line port)))
      (if (or (eof-object? lin) (string-null? lin))
        (reverse! ls)
        (let ((lin (string-trim-right lin)))
          (*read-line port) ;consume line
          (loop (cons (string-trim-both lin) ls))) ) ) ) )

;input-port -> string or #f
(define (read-label port)
  (let ((lbl (*read-line port)))
    (and (not (eof-object? lbl))
         (begin
           (when (leading-whitespace? lbl)
             (error 'read-label "label with leading whitespace" lbl))
           (unless (string-suffix? ":" lbl)
             (error 'read-label "label missing colon" lbl))
           (string-trim-right lbl #\:) ) ) ) )

;
(define (skip-whitelines port)
  (while (and (not (eof-object? (*peek-line port))) (string-null? (*peek-line port)))
    (*read-line port)) )

;input-port -> alist or #f
(define (read-info port)
  (let loop ((als '()))
    (skip-whitelines port)
    (let ((lbl (read-label port)))
      (if (not lbl)
        als
        (let ((cel `(,(string->symbol (string-downcase lbl)) . #f))
              (bdy (read-body port)) )
          (if (not bdy)
            (cons cel als)
            (begin
              (set-cdr! cel bdy)
              (loop (cons cel als))) ) ) ) ) ) )

;pathname -> alist or #f
(define (read-info-file pn)
  (call-with-input-file pn read-info #:text) )

;alist -> alist
(define (process-file als)
  (alist-update 'file (first (alist-ref 'file als)) als) )

;alist -> alist
(define (process-sha key als)
  (alist-update key (apply string-append (alist-ref key als)) als) )

;alist -> alist or #f
(define (process-info als)
  (and als
       (process-file
         (process-sha 'sha512
           (process-sha 'sha384
             (process-sha 'sha256 als))))) )

;pathname -> alist or #f
(define (read-testvector dir fn)
  (and-let* ((als (process-info (read-info-file (make-pathname dir fn)))))
    (alist-update 'data (read-vector-data (make-pathname dir (alist-ref 'file als))) als) ) )

;dirname -> list-of filename
(define (info-files dir)
  (filter (lambda (fn) (string=? "info" (pathname-extension fn))) (directory dir)) )

;dirname -> list-of alist
(define (load-testvectors dir)
  (map (cut read-testvector dir <>) (info-files dir)) )

(define (testvector-group-name als)
  (string-intersperse (alist-ref 'description als) "\n") )

(define (test-testvector als)
  (test-group (testvector-group-name als)
    (let ((dat (alist-ref 'data als)))
      (test (alist-ref 'sha256 als) (message-digest-u8vector (sha256-primitive) dat))
      (test (alist-ref 'sha384 als) (message-digest-u8vector (sha384-primitive) dat))
      (test (alist-ref 'sha512 als) (message-digest-u8vector (sha512-primitive) dat)) ) ) )

(for-each test-testvector (load-testvectors "./testvectors"))

(test-end "Sha2 Testvectors")

(test-exit)