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

(import test)

(test-begin "Message Digest Primitive")

;;;

(import (chicken blob) message-digest-primitive)

;;

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

(define just-once
  (let ((x #t))
    (lambda ()
      (let (
        (res (and x simple-src)) )
        (set! x #f)
        res ) ) ) )

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

;;

(test-group "Make Primitive"

	(define the-ctx #f)

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

  (define (update ctx bytes count)
    (assert (eq? ctx the-ctx))
    (assert (not (not bytes)))
    (assert (< 0 count))
    (void) )

  (define (final ctx result)
    (assert (eq? ctx the-ctx))
    (assert (not (not result)))
    (void) )

  (let (
    (mdp (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init update final)) )
    (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 BLOCK-LENGTH-DEFAULT (message-digest-primitive-block-length mdp))
    (test-assert (symbol? (message-digest-primitive-name mdp))) )

  ;;don't bother testing the non-optional arguments again

  (let (
    (mdp
      (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init update final #:name 'foo)) )
    (test BLOCK-LENGTH-DEFAULT (message-digest-primitive-block-length mdp))
    (test 'foo (message-digest-primitive-name mdp)) )

  (let (
    (mdp
      (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init update final #:block-length BLOCK-LENGTH)) )
    (test BLOCK-LENGTH (message-digest-primitive-block-length mdp))
    (test-assert (symbol? (message-digest-primitive-name mdp))) )

  (let (
    (mdp
      (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init update final #:block-length BLOCK-LENGTH #:name 'foo)) )
    (test BLOCK-LENGTH (message-digest-primitive-block-length 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)
    (set! the-ctx ctx)
    (assert (pointer? ctx)) )

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

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

  (let* (
    (mdp (make-message-digest-primitive CONTEXT-SIZE DIGEST-LENGTH init update final))
    (ctx (make-message-digest-primitive-context (message-digest-primitive-context-info mdp))) )
    (test-assert "allocated context" ctx)
    ;FIXME Add Life-Cycle Tests
    )
)

(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)
    (set! the-ctx ctx)
    (assert (blob? 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))
    (assert (blob? bytes))
    (assert (<= count (blob-size bytes)))
    (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? result))
    (assert (<= (blob-size result) DIGEST-LENGTH))  ; So no mem overflow
    (move-memory! ctx result DIGEST-LENGTH) )

  (let* (
    (mdp (make-message-digest-primitive make-context DIGEST-LENGTH init update final))
    (ctx (make-message-digest-primitive-context (message-digest-primitive-context-info mdp))) )
    (test-assert "allocated context" ctx)
    ;FIXME Add Life-Cycle Tests
    )
)

;;;

(test-end "Message Digest Primitive")

(test-exit)