;; Issues
;;

(module testvectors-test-support

(;export
  load-testvectors
  info-description)

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

;;

(define-type dirname string)
(define-type filename string)
(define-type pathname string)

(define-type alist (list-of pair))

(: info-description (alist --> string))
(: load-testvectors (dirname -> (list-of alist)))
(: info-files (dirname -> (list-of filename)))
(: info-filename? (pathname --> boolean))
(: read-testvector (dirname filename -> (or alist false)))
(: info-pathname (dirname alist -> pathname))
(: process-info ((or alist false) --> (or alist false)))
(: process-sha (symbol alist --> alist))
(: process-file (alist --> alist))
(: read-info-file (pathname -> (or alist false)))
(: read-info (input-port -> (or alist false)))
(: read-body (input-port -> (or string false)))
(: read-label (input-port -> (or string false)))
(: read-vector-data (pathname -> blob))
(: leading-whitespace? (string --> boolean))
(: skip-whitelines (input-port -> boolean))
(: *peek-line (input-port -> (or eof string)))
(: *read-line (input-port -> (or eof string)))

;;;

(define-constant MAX-DATA-LEN 1000000)

;;

;good enough
(define *peek-line)
(define *read-line)
(let ((+buf+ (the (or false eof string) #f)))
  (set! *peek-line
    (lambda (inp)
      (or +buf+
          (begin
            (set! +buf+ (read-line inp))
            +buf+))))
  (set! *read-line
    (lambda (inp)
      (if +buf+
        (let ((lin +buf+))
          (set! +buf+ #f)
          lin)
        (read-line inp)))) )

(define (skip-whitelines inp)
  (let loop ()
    (let ((lin (*peek-line inp)))
      (cond
        ((eof-object? lin)
          (*read-line inp) ;consume empty line
          #f )
        ((string-null? (string-trim lin))
          (*read-line inp) ;consume empty line
          (loop) )
        (else
          #t ) ) ) ) )

(define (leading-whitespace? lin)
  (let ((tlin (string-trim lin)))
    (or (string-null? tlin)
        (< (string-length tlin) (string-length lin))) ) )

(define (read-vector-data pn)
  (let ((dat (call-with-input-file pn (cut read-u8vector MAX-DATA-LEN <>) #:binary)))
    (if (eof-object? dat) (make-blob 0) (u8vector->blob dat)) ) )

(define (read-label inp)
  (let ((lbl (*read-line inp)))
    (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 (read-body inp)
  (define (finish-result ls)
    ;drop any trailing empty-line (convention in .info)
    (reverse! (if (string-null? (car ls)) (cdr ls) ls)) )
  (let loop ((ls '()))
    (let ((lin (*peek-line inp)))
      (if (eof-object? lin)
        (finish-result ls)
        (let* ((olin (string-trim-right lin))
               (lin (string-trim olin)) )
          ;no leading whitespace is termination
          (if (and (not (string-null? lin))
                   (= (string-length lin) (string-length olin)))
            (finish-result ls)
            (begin
              (*read-line inp) ;consume line
              (loop (cons lin ls)) ) ) ) ) ) ) )

(define (read-info inp)
  (define (finish-result als)
    (and (not (null? als)) als) )
  (define (canon-label lbl)
    (string->symbol (string-downcase lbl)) )
  (let loop ((als '()))
    (if (not (skip-whitelines inp))
      (finish-result als)
      (let ((lbl (read-label inp)))
        (if (not lbl)
          (finish-result als)
          (let* ((cel (cons (canon-label lbl) (read-body inp)))
                 (nals (cons cel als)) )
            (if (not (cdr cel))
              nals
              (loop nals) ) ) ) ) ) ) )

(define (read-info-file pn) (call-with-input-file pn read-info #:text))

(define (info-pathname dir als) (make-pathname dir (alist-ref 'file als)))

(define (info-filename? fn) (string=? "info" (pathname-extension fn)))

(define (info-files dir) (filter info-filename? (directory dir)))

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

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

(define (process-info als)
  (and als
       (process-file
         (process-sha 'sha512
           (process-sha 'sha384
             (process-sha 'sha256 als))))) )

(define (read-testvector dir fn)
  (and-let* ((als (process-info (read-info-file (make-pathname dir fn)))))
    (alist-update! 'data (read-vector-data (info-pathname dir als)) als) ) )

;;;

(define (load-testvectors dir) (map (cut read-testvector dir <>) (info-files dir)))

(define (info-description als) (string-intersperse (alist-ref 'description als) "\n"))

) ;module testvectors-test-support

;;;

(import scheme
  (chicken base)
  (chicken type)
  message-digest-byte-vector
  sha2
  test
  testvectors-test-support)

(define-type alist (list-of pair))

(: test-testvector (alist -> void))

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

;;

(test-begin "Sha2 Testvectors")

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

(test-end "Sha2 Testvectors")

(test-exit)