;;;; message-digest.scm
;;;; Kon Lovett, Jan '06

;; Issues
;;
;; - Renames the bindings of some string procedures to emphasize byte orientation.
;; This is a real kludge.

(module message-digest
	(export
	  ; Aux
		byte-string->substring-list/shared
		byte-string->substring-list
		byte-string->hexadecimal
		; Params
		message-digest-chunk-size
		message-digest-chunk-reader
		message-digest-chunk-converter
		;
		make-binary-message-digest
		make-message-digest
		;
		make-message-digest-primitive
		message-digest-primitive?
		message-digest-primitive-name
		message-digest-primitive-context-info
		message-digest-primitive-digest-length
		message-digest-primitive-init
		message-digest-primitive-update
		message-digest-primitive-final
		message-digest-primitive-apply)

(import (rename scheme (string-length byte-string-length)
                       (list->string list->byte-string)
                       (make-string make-byte-string))
        (except scheme string->list string-copy)
        (rename chicken (string->blob byte-string->blob))
        (only lolevel allocate free)
        (only srfi-1 map! reverse!)
        srfi-4
        (only srfi-13 substring/shared string-for-each string->list string-copy string-concatenate)
        (rename srfi-13 (substring/shared byte-substring/shared)
                        (string-for-each byte-string-for-each)
                        (string->list byte-string->list)
                        (string-copy byte-string-copy))
        (only srfi-69 hash)
        miscmacros
        type-checks
        type-errors)

(require-library lolevel srfi-1 srfi-4 srfi-13 srfi-69
                 miscmacros type-checks type-errors)

(declare
	(not usual-integrations
	  inexact->exact number? integer? round modulo)
	(fixnum)
	(inline)
	(no-procedure-checks) )

;;;

(define (context-info? obj) (or (and (fixnum? obj) (positive? obj)) (procedure? obj)))

(define-check+error-type message-digest-primitive)
(define-check-type context-info)
(define-error-type context-info "positive fixnum or procedure")

(define (check-message-digest-parameters loc ctx-info digest-len init update final)
  (check-context-info loc ctx-info 'context-info)
	(check-positive-integer loc digest-len 'digest-length)
	(check-procedure loc init)
  (check-procedure loc update)
  (check-procedure loc final) )

;;; Byte string utilities

(define (byte-string->substring-list/shared str chunk-size #!optional (start 0) (end (byte-string-length str)))
  (let* ((rem (remainder (- end start) chunk-size))
         (len (- end rem))
         (sublst
          (let loop ((pos start) (lst '()))
            (if (>= pos len) (reverse! lst)
                (let ((npos (+ pos chunk-size)))
                  (loop npos (cons (byte-substring/shared str pos npos) lst)))))))
      (if (zero? rem) sublst
          (append sublst (list (byte-substring/shared str len end))) ) ) )

(define (byte-string->substring-list str chunk-size #!optional (start 0) (end (byte-string-length str)))
  (map! byte-string-copy (byte-string->substring-list/shared str chunk-size start end)) )

(define (byte-string->hexadecimal str #!optional (start 0) (end (byte-string-length str)))
  (define (byte-char->hex ch)
    (let* ((int (char->integer ch))
           (str (number->string int 16)))
      (if (< int 16) (string-append "0" str) str) ) )
  (string-concatenate (map! byte-char->hex (byte-string->list str start end))) )

;;;

(define (default-chunk-reader in)
  (let* ((siz (message-digest-chunk-size))
         (u8buf (make-u8vector siz)) )
    (lambda ()
      (let ((len (read-u8vector! siz u8buf in)))
        (and (positive? len)
             (u8vector->blob/shared u8buf) ) ) ) ) )

(define (default-chunk-converter obj)
  (cond ((u8vector? obj)        (u8vector->blob/shared obj))
        ((s8vector? obj)        (s8vector->blob/shared obj))
        ((u16vector? obj)       (u16vector->blob/shared obj))
        ((s16vector? obj)       (s16vector->blob/shared obj))
        ((u32vector? obj)       (u32vector->blob/shared obj))
        ((s32vector? obj)       (s32vector->blob/shared obj))
        ((f32vector? obj)       (f32vector->blob/shared obj))
        ((f64vector? obj)       (f64vector->blob/shared obj))
        (else                   obj ) ) )

(define-inline (byte-object-size obj)
  (cond ((blob? obj)    (blob-size obj))
        ((string? obj)  (byte-string-length obj))
        (else           -1) ) )

;;;

(define-constant default-chunk-size 1024)

(define-parameter message-digest-chunk-size default-chunk-size
  (lambda (x)
    (cond ((and (fixnum? x) (positive? x)) x)
          (else
           (warning 'message-digest-chunk-size (make-error-type-message "positive fixnum") x)
           (message-digest-chunk-size) ) ) ) )

(define-parameter message-digest-chunk-reader default-chunk-reader
  (lambda (x)
    (cond ((procedure? x) x)
          (else
           (warning 'message-digest-chunk-reader (make-error-type-message "procedure") x)
           (message-digest-chunk-reader) ) ) ) )

(define-parameter message-digest-chunk-converter default-chunk-converter
  (lambda (x)
    (cond ((or (not x) (procedure? x)) x)
          (else
           (warning 'message-digest-chunk-converter (make-error-type-message "procedure or #f") x)
           (message-digest-chunk-converter) ) ) ) )

;;;

(define (%make-binary-message-digest src ctx-info digest-len init updt fin id)
  (letrec ((ctx #f)
           (update-while (lambda (proc) (while* (proc) (updt ctx it (byte-object-size it))))) )
    (dynamic-wind
      (lambda ()
        (set! ctx (if (fixnum? ctx-info) (allocate ctx-info) (ctx-info))) )
      (lambda ()
        (init ctx)
        (cond ((string? src)
               (updt ctx src (byte-string-length src)) )
              ((blob? src)
               (updt ctx src (blob-size src)) )
              ((input-port? src)
               (update-while ((message-digest-chunk-reader) src)) )
              ((procedure? src)
               (update-while src) )
              (((message-digest-chunk-converter) src)
               => (lambda (buf) (updt ctx buf (byte-object-size buf))) )
              (else
               (updt ctx src -1) ) )
        (let ((result (make-byte-string digest-len)))
          (fin ctx result)
          result ) )
      (lambda ()
        (when (and ctx (fixnum? ctx-info)) (free ctx)) ) ) ) )

;;;

(define (make-binary-message-digest src ctx-info digest-len init update final #!optional (caller 'make-binary-message-digest))
  (check-message-digest-parameters caller ctx-info digest-len init update final)
  (%make-binary-message-digest src ctx-info digest-len init update final caller) )

(define (make-message-digest src ctx-info digest-len init update final #!optional (caller 'make-message-digest))
	(byte-string->hexadecimal (make-binary-message-digest src ctx-info digest-len init update final caller)) )

;;;

(define-record-type message-digest-primitive
	(%make-message-digest-primitive ctx-info digest-len init update final name)
	message-digest-primitive?
	(ctx-info message-digest-primitive-context-info)
	(digest-len message-digest-primitive-digest-length)
	(init message-digest-primitive-init)
	(update message-digest-primitive-update)
	(final message-digest-primitive-final)
	(name message-digest-primitive-name) )

(define (make-message-digest-primitive ctx-info digest-len init update final . name)
  (check-message-digest-parameters 'make-binary-message-digest-primitive ctx-info digest-len init update final)
	(%make-message-digest-primitive ctx-info digest-len init update final (optional name (gensym "mdp"))) )

(define (message-digest-primitive-apply mdp src #!optional (caller 'message-digest-primitive-apply))
  (check-message-digest-primitive caller mdp)
	(%make-binary-message-digest
	 src
	 (message-digest-primitive-context-info mdp)
	 (message-digest-primitive-digest-length mdp)
	 (message-digest-primitive-init mdp)
	 (message-digest-primitive-update mdp)
	 (message-digest-primitive-final mdp)
	 (message-digest-primitive-name mdp)) )

) ;module message-digest