;;;; message-digest-utils-test.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18

;; Issues
;;
;; - Needs many more tests, especially the entire input-port & procedure source stuff.

(import test)

(cond-expand
  (compiling
    (print)
    (print "*****")
    (print "* Expect compiler warnings")
    (print "*****") )
  (else) )

(test-begin "Message Digest Utils")

;;;

(import scheme)
(import (chicken base))
(import (chicken type))
;(import (chicken format))
(import (chicken fixnum))
(import (chicken blob))
(import (chicken memory))
(import (srfi 4))
(import message-digest-primitive)
(import message-digest-type)
(import message-digest-chunk)
(import message-digest-port)
(import message-digest-srfi-4)
(import message-digest-int)
(import message-digest-update-item)
(import message-digest-item)
(import message-digest-byte-vector)

;;

(define (char-hex c) (number->string (char->integer c) 16))
(define (string-hex s) (apply string-append (map char-hex (string->list s))))

(define simple-src "ab cd")
(define simple-res (string-hex simple-src))

(define-constant DIGEST-LENGTH 5)
(define-constant CONTEXT-SIZE 10)
(define-constant BLOCK-LENGTH 64)

(define-constant BLOCK-LENGTH-DEFAULT 4)

(define SHORT-TEST-FILE-NAME "alpha.txt")
(define SHORT-TEST-FILE-LENGTH 26)

;type must be (or DATA false)
(: just-once (-> (or string false)))
(define just-once
  ;override most specific inferred type - true - w/ what is needed
  (let ((flag (the boolean #t)))
    (lambda ()
      (and flag (begin (set! flag #f) simple-src)))))

;FIXME add (mock-*-primitive ...) that wraps the supplied phase procedures

;;

(test 'hex-string (message-digest-result-form 'hex))

;Tests defaults
(test-group "Chunk Read (port)"
  (let ((siz (message-digest-chunk-size))
        (in (open-input-file SHORT-TEST-FILE-NAME)) )
    (let* ((rdr ((message-digest-chunk-port-read-maker) in))
           (res (rdr)) )
      (test-assert "First chunk type" (blob? res))
      (test "First chunk size" SHORT-TEST-FILE-LENGTH (blob-size res))
      (test-assert "No more chunk" (not (rdr))) )
    (close-input-port in) )
)

(let ()

	(define the-ctx #f)

  (define (make-context)
    ;Init to 0 necessary since DIGEST-LENGTH is possibly > than
    ;the input size! (Actually just needs to be a known value,
    ;`(integer->char #xff)' would work as well.)
    (string->blob (make-string CONTEXT-SIZE #\nul)) )

  (define (init ctx)
    (set! the-ctx ctx) )

  (define (update ctx bytes count)
    ;(printf "Update Ctx: ~S Bytes: ~S Count: ~S~%" ctx bytes count) (flush-output)
    (assert (eq? ctx the-ctx))
    (assert (not (not bytes)))
    (assert (< 0 count))
    (assert (<= count CONTEXT-SIZE))  ; So no mem overflow
    (assert (blob? ctx))
    (move-memory! bytes ctx count) )

  (define (final ctx result)
    ;(printf "Final Result Size: ~S Ctx: ~S Result: ~S~%" (blob-size result) ctx result) (flush-output)
    (assert (eq? ctx the-ctx))
    (assert (not (not result)))
    (assert (blob? ctx))
    (assert (<= (blob-size result) DIGEST-LENGTH))  ; So no mem overflow
    (move-memory! ctx result DIGEST-LENGTH) )

  (define mdp (make-message-digest-primitive make-context DIGEST-LENGTH init update final))

  (test-group "string Source"
    (let ((md (setup-message-digest mdp)))
      (test-assert (message-digest-update-string md (string #\1 #\2 #\3 #\4 #\5)))
      (test "3132333435" (finalize-message-digest md)) )
  )

  (test-group "blob Source"
    (let ((md (setup-message-digest mdp)))
      (test-assert (message-digest-update-blob md #${3132333435}))
      (test "3132333435" (finalize-message-digest md)) )
  )

  (test-group "u8vector Source"
    (let ((md (setup-message-digest mdp)))
      (test-assert (message-digest-update-u8vector md (u8vector 1 2 3 4 5)))
      (test "0102030405" (finalize-message-digest md)) )
  )

  (test-group "u8 Source"
    (let ((md (setup-message-digest mdp)))
      (test-assert (message-digest-update-u8 md #xA2))
      (test "a200000000" (finalize-message-digest md)) )
  )

  (test-group "u16-le Source"
    (let ((md (setup-message-digest mdp)))
      (test-assert (message-digest-update-u16-le md #xA2B2))
      (test "b2a2000000" (finalize-message-digest md)) )
  )

  (test-group "u32-be Source"
    (let ((md (setup-message-digest mdp)))
      (test-assert (message-digest-update-u32-be md 1073741823))
      (test "3fffffff00" (finalize-message-digest md)) )
  )

  (test-group "u32-be Source"
    (let ((md (setup-message-digest mdp)))
      (test-assert (message-digest-update-u32-be md #xA2B2C2D2))
      (test "a2b2c2d200" (finalize-message-digest md)) )
  )

  (test-group "u64-be Source"
    (let ((md (setup-message-digest mdp)))
      (test-assert (message-digest-update-u64-be md #xAB54A98CEB1F0AD2))
      (test
        (substring "ab54a98ceb1f0ad2" 0 (fx* 2 (fxmin 8 DIGEST-LENGTH)))
        (finalize-message-digest md)) )
  )

  (test-group "char-u8 Source"
    (let ((md (setup-message-digest mdp)))
      (test-assert (message-digest-update-char-u8 md #\space))
      (test "2000000000" (finalize-message-digest md)) )
  )

  (test-group "char-be Source"
    (let ((md (setup-message-digest mdp)))
      (test-assert (message-digest-update-char-be md #\u0003BB))
      (test "000003bb00" (finalize-message-digest md)) )
  )

  (test-group "char-le Source"
    (let ((md (setup-message-digest mdp)))
      (test-assert (message-digest-update-char-le md #\u0003BB))
      (test "bb03000000" (finalize-message-digest md)) )
  )

  (test-group "Port"
    (let-values (((port md) (open-output-digest mdp)))
      (test-assert (digest-output-port? port))
      (display simple-src port) ;cannot be readable! (??)
      (test simple-res (get-output-digest port md))
      (test-assert (port-closed? port)) )
  )

  (test-group "Procedure Source"
    (let ((md (setup-message-digest mdp)))
      (test-assert (message-digest-update-procedure md just-once))
      (test simple-res (finalize-message-digest md)) )
  )

  (test-group "re-use"
    (let ((md (setup-message-digest mdp)))
      ;bug reported by klm sep 25 2024 on CHICKEN IRC
      (test-error "checks args" (message-digest-string md "data" "wrong form"))
      (test-error "checks args" (message-digest-string md "data" 'string 'a 3))
      (test "3132333435" (message-digest-string md (string #\1 #\2 #\3 #\4 #\5)))
      (test "3534333231" (message-digest-string md (string #\5 #\4 #\3 #\2 #\1))) )
  )
)

;
(test-group "Chunk Read (fileno)"

	(define the-ctx #f)

  (define (init ctx)
    ;(printf "  Init Ctx: ~S~%" ctx)
    (assert (pointer? ctx))
    (set! the-ctx ctx) )

  (define (update ctx bytes count)
  	;(printf "Update Ctx: ~S Count: ~S Bytes: ~S~%" ctx count bytes)
    (assert (eq? ctx the-ctx))
    (assert (not (not bytes)))
    (assert (< 0 count))
    (assert (<= count CONTEXT-SIZE))
    (assert (pointer? ctx))
    (move-memory! bytes ctx count) )

  (define (raw-update ctx bytes count)
  	;(printf "Raw-Update Ctx: ~S Count: ~S Bytes: ~S~%" ctx count bytes)
    (assert (eq? ctx the-ctx))
    (assert (not (not bytes)))
    (assert (< 0 count))
    (assert (= SHORT-TEST-FILE-LENGTH count))
    (assert (pointer? ctx))
    (move-memory! bytes ctx (min CONTEXT-SIZE count)) )

  (define (final ctx result)
    ;(printf " Final Ctx: ~S Length: ~S Result: ~S~%" ctx DIGEST-LENGTH result)
    (assert (eq? ctx the-ctx))
    (assert (not (not result)))
    (assert (pointer? ctx))
    ;(assert (<= 0 DIGEST-LENGTH))
    (move-memory! ctx result DIGEST-LENGTH) )

  (let ((mdp
          (make-message-digest-primitive
            CONTEXT-SIZE DIGEST-LENGTH
            init update final #:raw-update raw-update)) )
    (test "6162636465" (message-digest-file mdp SHORT-TEST-FILE-NAME 'hex-string)) )
)

;;;

(test-end "Message Digest Utils")

(test-exit)