;;;; 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? byte-string?)
            (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)
          (only miscmacros while* define-parameter)
          (only type-checks
            define-check+error-type
            check-positive-integer check-procedure)
          (only type-errors warning-argument-type signal-type-error))

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

;;;

(define (context-info? obj) (or (and (fixnum? obj) (positive? obj)) (procedure? obj)))
(define-check+error-type context-info 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-inline (byte-object-size obj)
  (cond ((blob? obj)        (blob-size obj))
        ((byte-string? obj) (byte-string-length obj))
        (else               -1) ) )

(define (srfi-4-vector->blob 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                   #f ) ) )

;;;

(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-argument-type 'message-digest-chunk-size x 'positive-fixnum)
           (message-digest-chunk-size) ) ) ) )

(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-parameter message-digest-chunk-reader default-chunk-reader
  (lambda (x)
    (cond ((procedure? x) x)
          (else
           (warning-argument-type 'message-digest-chunk-reader x 'procedure)
           (message-digest-chunk-reader) ) ) ) )

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

;;;

(define (update-while ctx proc updt) (while* (proc) (updt ctx it (byte-object-size it))))

(define (update-how loc ctx src updt)
  (cond ((byte-string? src)   (updt ctx src (byte-string-length src)) )
        ((blob? src)          (updt ctx src (blob-size src)) )
        ((input-port? src)    (update-while ctx ((message-digest-chunk-reader) src) updt) )
        ((procedure? src)     (update-while ctx src updt) )
        ((srfi-4-vector->blob src)
                              => (lambda (buf) (updt ctx buf (blob-size buf))) )
        ((and-let* ((cnv (message-digest-chunk-converter))) (cnv src))
                              => (lambda (buf) (updt ctx buf (byte-object-size buf))) )
        (else                 ;; (updt ctx src -1)    ;; clients crash on -1
                              (signal-type-error loc "indigestible object" src) ) ) )

(define (%make-binary-message-digest loc src ctx-info digest-len init updt fin)
  (let ((ctx #f))
    (dynamic-wind
      (lambda () (set! ctx (if (fixnum? ctx-info) (allocate ctx-info) (ctx-info))))
      (lambda ()
        (init ctx)
        (update-how loc ctx src updt)
        (let ((res (make-byte-string digest-len))) (fin ctx res) res))
      (lambda () (when (and ctx (fixnum? ctx-info)) (free ctx)))) ) )

;;;

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

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

;;;

(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-check+error-type message-digest-primitive)

(define (make-message-digest-primitive ctx-info digest-len init update final
                                       #!optional (name (gensym "mdp")))
  (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 name) )

(define (message-digest-primitive-apply mdp src #!optional (loc 'message-digest-primitive-apply))
  (check-message-digest-primitive loc mdp)
	(%make-binary-message-digest
	 (or (message-digest-primitive-name mdp) loc)
	 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)) )

) ;module message-digest