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

(import test)

(test-begin "Message Digest Primitive")

;;;

(import message-digest-primitive)

;;

(import (chicken blob))

;;

(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 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 mdp)) )
    (test-assert "allocated context" ctx)
    ;FIXME Add Life-Cycle Tests
    )
)

;uses foreign
#+compiling
(begin
  (import (chicken foreign) (chicken memory))
  (test-group "Raw => Cooked"

    (define the-ctx #f)

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

    (define raw-update
      (foreign-lambda* void ((c-pointer pctx) (c-pointer pdat) (unsigned-int n))
        "memmove( pctx, pdat, n );"))

    (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 #f final #:raw-update raw-update))
      (ctx (make-message-digest-primitive-context mdp)) )
      (test-assert "allocated context" (pointer? ctx))
      (test-assert "initialize" ((message-digest-primitive-init mdp) ctx))
      (test "initialize worked" the-ctx ctx)
      (test-assert "generated update" (procedure? (message-digest-primitive-update mdp)))
      (test-assert "update" ((message-digest-primitive-update mdp) ctx "foobar" 3))
      (test "update worked" #\f (integer->char (pointer-u8-ref ctx)))
      ;FIXME bugs in chicken memory ?
      (test-assert "BUG?: @ptr != @(ptr + 0)" (not (equal? (pointer->address ctx) (pointer->address (pointer+ ctx 0)))))
      ;
      ;(print "@+0: " (+ (pointer->address ctx) 0))
      ;(print "@+0<->: " (pointer->address (address->pointer (+ (pointer->address ctx) 0))))
      ;
      ;Error: segmentation violation
      ;(test-assert (pointer-u8-ref (address->pointer (+ (pointer->address ctx) 0))))
      ;
      ;(test "f[oo]" #\f (integer->char (pointer-u8-ref (address->pointer (+ (pointer->address ctx) 0)))))
      ;
      ;(print (pointer->address ctx))
      ;(print (pointer->address (pointer+ ctx 0)))
      ;(print (pointer->address (pointer+ ctx 1)))
      ;(print (pointer->address (pointer+ ctx 2)))
      ;
      ;(test "f[oo]" #\f (integer->char (pointer-u8-ref (pointer+ ctx 0))))
      ;(test "fo[o]" #\o (integer->char (pointer-u8-ref (pointer+ ctx 1))))
      ;(test "foo[]" #\o (integer->char (pointer-u8-ref (pointer+ ctx 2))))
    )
  )
)

;;;

(test-end "Message Digest Primitive")

(test-exit)