;;;; message-digest-test.scm

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

(use test)
(use message-digest message-digest-port)
(use files lolevel srfi-4)
(use setup-api)

;;

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

(define simple-src "ab cd")
(define simple-res (ashexstr simple-src))

(define digest-length 5)
(define context-size 10)

;;

(test-begin "Message Digest")

;Tests defaults
(test-group "Chunk Read"
  (let ((siz (message-digest-chunk-size))
        (in (open-input-file "alpha.txt")))
    (let ((rdr ((message-digest-chunk-read-maker) in)))
      (let ((res (rdr)))
        (test-assert "First chunk type" (blob? res))
        (test "First chunk size" 26 (blob-size res)) )
      (test-assert "No more chunk" (not (rdr))) )
    (close-input-port in) )
)

(test-group "Make Primitive"

  (define (init ctx) (void))
  (define (update ctx bytes count) (void))
  (define (final ctx result) (void))

  (let ((mdp (make-message-digest-primitive context-size digest-length init update final 'foo)))
    (test-assert (message-digest-primitive? mdp))
    (test context-size (message-digest-primitive-context-info mdp))
    (test digest-length (message-digest-primitive-digest-length mdp))
    (test init (message-digest-primitive-init mdp))
    (test update (message-digest-primitive-update mdp))
    (test final (message-digest-primitive-final mdp))
    (test 'foo (message-digest-primitive-name mdp)) )
)

;These also test the update-string proc
(test-group "Proper Phase Arguments (Def Alloc)"

	(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 Bytes: ~S Count: ~S~%" ctx bytes count)
    (assert (pointer? ctx))
    (assert (eq? ctx the-ctx))
    (assert (blob? bytes))
    (assert (<= count (blob-size bytes)))
    (assert (>= context-size count))  ; So no mem overflow
    (move-memory! bytes ctx count) )

  (define (final ctx result)
    ;(printf " Final Ctx: ~S Result: ~S~%" ctx result)
    (assert (pointer? ctx))
    (assert (eq? ctx the-ctx))
    (assert (blob? result))
    (assert (= digest-length (blob-size result)))  ; So no mem overflow
    (move-memory! ctx result digest-length) )

  (let ((mdp (make-message-digest-primitive context-size digest-length init update final)))
    (let ((md (initialize-message-digest mdp)))
      (test-assert (message-digest? md))
      (test-assert (message-digest-update-string md simple-src))
      (test simple-res (finalize-message-digest md)) ) )
)

(test-group "Proper Phase Arguments (Own Alloc)"

	(define the-ctx #f)

  (define (make-context) (make-blob context-size))

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

  (define (update ctx bytes count)
    ;(printf "Update Ctx: ~S Bytes: ~S Count: ~S~%" ctx bytes count) (flush-output)
    (assert (blob? ctx))
    (assert (eq? ctx the-ctx))
    (assert (blob? bytes))
    (assert (<= count (blob-size bytes)))
    (assert (>= context-size count))  ; So no mem overflow
    (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 (blob? ctx))
    (assert (eq? ctx the-ctx))
    (assert (blob? result))
    (assert (= digest-length (blob-size result)))  ; So no mem overflow
    (move-memory! ctx result digest-length) )

  (let ((mdp (make-message-digest-primitive make-context digest-length init update final)))
    (let ((md (initialize-message-digest mdp)))
      (test-assert (message-digest? md))
      (test-assert (message-digest-update-string md simple-src))
      (test simple-res (finalize-message-digest md)) ) )
)

(let ()

  (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) (void))

  (define (update ctx bytes count)
    ;(printf "Update Ctx: ~S Bytes: ~S Count: ~S~%" ctx bytes count) (flush-output)
    (assert (>= context-size count))  ; So no mem overflow
    (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 (= digest-length (blob-size result)))  ; 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 "u8vector Source"
    (let ((md (initialize-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 (initialize-message-digest mdp)))
      (test-assert (message-digest-update-u8 md #xA2))
      (test "a200000000" (finalize-message-digest md)) )
  )

  (test-group "u16-le Source"
    (let ((md (initialize-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 (initialize-message-digest mdp)))
      (test-assert (message-digest-update-u32-be md 1073741823))
      (test "3fffffff00" (finalize-message-digest md)) )
  )

  (when (version>=? (chicken-version) "4.6.4")
	  (test-group "u32-be Source"
			(let ((md (initialize-message-digest mdp)))
				(test-assert (message-digest-update-u32-be md #xA2B2C2D2))
				(test "a2b2c2d200" (finalize-message-digest md)) )
		) )

  (when (version>=? (chicken-version) "4.8.1")
		(test-group "u64-be Source"
			(let ((md (initialize-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 (initialize-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 (initialize-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 (initialize-message-digest mdp)))
      (test-assert (message-digest-update-char-le md #\u0003BB))
      (test "bb03000000" (finalize-message-digest md)) )
  )

  (test-group "Procedure Source"
    (define just-once
      (let ((x #t))
        (lambda ()
          (let ((res (and x simple-src)))
            (set! x #f)
            res ) ) ) )
    (let ((md (initialize-message-digest mdp)))
      (test-assert (message-digest-update-procedure md just-once))
      (test simple-res (finalize-message-digest md)) )
  )

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

#; ;REMOVED
(begin
	(use message-digest-old)

  (define (make-context)
    (string->blob (make-string context-size #\nul)) )

  (define (init ctx) (void))

  (define (update ctx bytes count)
    (assert (>= context-size count))  ; So no mem overflow
    (move-memory! bytes ctx count) )

  (define (final ctx result)
    (assert (= digest-length (blob-size result)))  ; So no mem overflow
    (move-memory! ctx result digest-length) )

  (test-group "Primitive Apply (DEPRECATED)"
    (let ((mdp (make-message-digest-primitive context-size digest-length init update final)))
      (let ((res (message-digest-primitive-apply mdp simple-src)))
        (test-assert (string? res))
        (test simple-res (byte-string->hexadecimal res)) ) )
  )

  (test-group "Make (DEPRECATED)"
    (test simple-src (make-binary-message-digest simple-src make-context digest-length init update final))
    (test simple-res (make-message-digest simple-src make-context digest-length init update final))
  )
)

(test-end)

(test-exit)