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

;; Issues
;;
;; - Use of 'sys namespace procedures.
;;
;; - Uses string type as a byte-vector - a kludge.
;;
;; - Uses 'context-info' to determine whether active context is "own" allocation or
;; callers. Again, a kludge.
;;
;; - Passes u8vector to update phase as a blob.

(module message-digest

	(;export
	  ; Aux
		byte-string->hexadecimal    ;FIXME this doesn't belong here
		; Parameters
		message-digest-chunk-size
		message-digest-chunk-read-maker
		message-digest-chunk-converter
		; Algorithm API
		make-message-digest-primitive
		message-digest-primitive? check-message-digest-primitive error-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
		; MD API
		message-digest? check-message-digest error-message-digest
		message-digest-algorithm
		message-digest-context
		initialize-message-digest
		*message-digest-update ;For internal use
		finalize-message-digest
		message-digest-update-object
		message-digest-update-blob
		message-digest-update-string
		message-digest-update-substring
		message-digest-update-u8vector
		message-digest-update-subu8vector
		message-digest-update-char
		message-digest-update-u8
		message-digest-update-u16
		message-digest-update-u16-be
		message-digest-update-u16-le
		message-digest-update-u32
		message-digest-update-u32-be
		message-digest-update-u32-le
		message-digest-update-u64
		message-digest-update-u64-be
		message-digest-update-u64-le
		message-digest-update-procedure
		message-digest-update-port
		message-digest-update-file
		;
		message-digest-object
		message-digest-string
		message-digest-blob
		message-digest-u8vector
		message-digest-file
		; DEPRECATED
		make-binary-message-digest
		make-message-digest
		message-digest-primitive-apply)

  (import
    scheme
    chicken
    foreign
    (only lolevel allocate free)
    srfi-4
    (only srfi-13 substring/shared)
    (only miscmacros while* define-parameter)
    (only type-checks
      define-check+error-type
      check-integer check-positive-integer
      check-blob check-string check-char
      check-input-port check-procedure)
    (only srfi-4-checks check-u8vector)
    (only type-errors
      make-error-type-message
      error-argument-type warning-argument-type signal-type-error))

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

;;; Byte string utilities

(define-inline (%setchar s i c) (##core#inline "C_setsubchar" s i c))

(define string->hex
  (let ((digits '#(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\a #\b #\c #\d #\e #\f)))
    (lambda (str #!optional (start 0) (end #f))
      (##sys#check-string str 'string->hex)
      (let ((end (or end (##sys#size str))))
        (unless (fx<= start end)
          (##sys#signal-hook #:bounds-error 'string->hex
                             ;"out of range"
                             "illegal substring specification" start end))
        (let ((res (##sys#make-string (fx* (fx- end start) 2))))
          (do ((i start (fx+ i 1))
               (j 0 (fx+ j 2)) )
              ((fx>= i end) res)
            (let ((byte (##sys#byte str i)))
              (%setchar res j (vector-ref digits (fxand (fxshr byte 4) #xf)))
              (%setchar res (fx+ j 1) (vector-ref digits (fxand byte #xf))) ) ) ) ) ) ) )

(define byte-string->hexadecimal string->hex)

;;; Message DIgest Parameters

(define-constant default-chunk-size 1024)

(define-parameter message-digest-chunk-size default-chunk-size
  (lambda (x)
    (cond ((and (integer? x) (positive? x)) x)
          (else
           (warning-argument-type 'message-digest-chunk-size x 'positive-integer)
           (message-digest-chunk-size) ) ) ) )

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

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

;;; Helpers

(define-inline (check-message-digest-arguments loc ctx-info digest-len init update final)
  (unless (or (procedure? ctx-info)
              (and (integer? ctx-info) (positive? ctx-info)))
    (error-argument-type loc ctx-info "positive-integer or procedure" 'context-info) )
	(check-positive-integer loc digest-len 'digest-length)
	(check-procedure loc init 'digest-initializer)
  (check-procedure loc update 'digest-updater)
  (check-procedure loc final 'digest-finalizer) )

(define-inline (get-message-digest-context ctx-info)
  (if (procedure? ctx-info) (ctx-info)
      (let ((mem (allocate ctx-info)))
        (set-finalizer! mem free)
        mem ) ) )

(define (XXXvector->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-inline (chunk-convert src)
  (and-let* ((cnv (message-digest-chunk-converter))) (cnv src)) )

(define (do-bytes-update loc ctx src updt)
  (cond ((string? src)        (updt ctx src (string-length src)) )
        ((blob? src)          (updt ctx src (blob-size src)) )
        ((or (XXXvector->blob src)
             (chunk-convert src))
                              => (cut do-bytes-update loc ctx <> updt) )
        (else
          (signal-type-error loc "indigestible object" src) ) ) )

(define-inline (do-procedure-update loc ctx proc updt)
  (while* (proc) (do-bytes-update loc ctx it updt) ) )

(define-inline (chunk-reader-for-source src) ((message-digest-chunk-read-maker) src))

(define-inline (do-update loc ctx src updt)
  (cond ((input-port? src)    (do-procedure-update loc ctx (chunk-reader-for-source src) updt) )
        ((procedure? src)     (do-procedure-update loc ctx src updt) )
        (else                 (do-bytes-update loc ctx src updt) ) ) )

(define-inline (string->u8vector bs) (blob->u8vector/shared (string->blob bs)))

(define (get-result-as-type loc res rt)
  (case rt
    ((string byte-string) res )
    ((hexstring hex)      (string->hex res) )
    ((blob)               (string->blob res) )
    ((u8vector)           (string->u8vector res) )
    (else
      (error-argument-type loc rt "symbol: 'string, 'hex, 'blob, 'u8vector" 'result-form) ) ) )

(define (error-byte-order loc obj)
  (error-argument-type loc obj "symbol: 'big-endian or 'little-endian" 'byte-order) )

; Pack a 16-, 32-, or 64-bit integer into a u8 vector with endian order
(define u64->u8vector!
  (foreign-lambda* void ((nonnull-u8vector u8vec)
                         (integer64 n)
                         (integer start) (integer end) (integer inc))
    "int bitcnt = 0;\n"
    ; 2 bytes
    "u8vec[start] = ((uint64_t) n) & 0xff;\n"
    "u8vec[start += inc] = (((uint64_t) n) >> (bitcnt += 8)) & 0xff;\n"
    "if ((start += inc) != end) {\n"
    ; 4 bytes
    "	u8vec[start] = (((uint64_t) n) >> (bitcnt += 8)) & 0xff;\n"
    "	u8vec[start += inc] = (((uint64_t) n) >> (bitcnt += 8)) & 0xff;\n"
    "	if ((start += inc) != end) {\n"
    ; 8 bytes
      "	u8vec[start] = (((uint64_t) n) >> (bitcnt += 8)) & 0xff;\n"
      "	u8vec[start += inc] = (((uint64_t) n) >> (bitcnt += 8)) & 0xff;\n"
      "	u8vec[start += inc] = (((uint64_t) n) >> (bitcnt += 8)) & 0xff;\n"
      "	u8vec[start += inc] = (((uint64_t) n) >> (bitcnt += 8)) & 0xff;\n"
    "	}\n"
    "}\n"))

;;; Message Digest Algorithm API

(define-record-type message-digest-primitive
	(*make-message-digest-primitive ctxi digest-len init update final name)
	message-digest-primitive?
	(ctxi 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-arguments 'make-message-digest-primitive
    ctx-info digest-len init update final)
  (*make-message-digest-primitive
    ctx-info
    digest-len
    init update final
    name) )

;;; Message Digest API

;;

(define-record-type message-digest
	(*make-message-digest mdp ctx)
	message-digest?
	(mdp message-digest-algorithm)
	(ctx message-digest-context) )

(define-check+error-type message-digest)

(define (initialize-message-digest mdp)
  (check-message-digest-primitive 'initialize-message-digest mdp)
  (let ((ctx (get-message-digest-context (message-digest-primitive-context-info mdp))))
    ((message-digest-primitive-init mdp) ctx)
    (*make-message-digest mdp ctx) ) )

(define (*message-digest-update md src len)
  (let ((mdp (message-digest-algorithm md))
        (ctx (message-digest-context md)) )
    ((message-digest-primitive-update mdp) ctx src len) ) )

(define (finalize-message-digest md #!optional (result-type 'hex))
  (check-message-digest 'finalize-message-digest md)
  (let ((mdp (message-digest-algorithm md))
        (ctx (message-digest-context md)) )
    (let ((res (##sys#make-string (message-digest-primitive-digest-length mdp))))
      ((message-digest-primitive-final mdp) ctx res)
      (get-result-as-type 'finalize-message-digest res result-type) ) ) )

(define (message-digest-update-object md src)
  (check-message-digest 'message-digest-update-object md)
  (let ((mdp (message-digest-algorithm md))
        (ctx (message-digest-context md)) )
    (do-update 'message-digest-update-object ctx src (message-digest-primitive-update mdp)) ) )

(define-inline (*message-digest-update-blob md src)
  (let ((mdp (message-digest-algorithm md))
        (ctx (message-digest-context md)) )
    ((message-digest-primitive-update mdp) ctx src (blob-size src)) ) )

(define (message-digest-update-blob md src)
  (check-message-digest 'message-digest-update-blob md)
  (check-blob 'message-digest-update-blob src)
  (*message-digest-update-blob md src) )

(define-inline (*message-digest-update-string md src)
  (let ((mdp (message-digest-algorithm md))
        (ctx (message-digest-context md)) )
    ((message-digest-primitive-update mdp) ctx src (##sys#size src)) ) )

(define (message-digest-update-string md src)
  (check-message-digest 'message-digest-update-string md)
  (check-string 'message-digest-update-string src)
  (*message-digest-update-string md src) )

(define (message-digest-update-substring md src start end)
  (check-message-digest 'message-digest-update-substring md)
  (check-string 'message-digest-update-substring src)
  (*message-digest-update-string md (substring/shared src start end)) )

(define (message-digest-update-u8vector md src)
  (check-message-digest 'message-digest-update-u8vector md)
  (check-u8vector 'message-digest-update-u8vector src)
  (*message-digest-update-blob md (u8vector->blob/shared src)) )

(define (message-digest-update-subu8vector md src start end)
  (check-message-digest 'message-digest-update-u8vector md)
  (check-u8vector 'message-digest-update-u8vector src)
  (*message-digest-update-blob md (u8vector->blob/shared (subu8vector src start end))) )

#; ;Probably not a useful interface
(define (message-digest-update-XXXvector md src)
  (check-message-digest 'message-digest-update-XXXvector md)
  (let ((blob (XXXvector->blob src)))
    (if blob (*message-digest-update-blob md blob)
        (error-argument-type 'message-digest-update-XXXvector src 'srfi-4-vector) ) ) )

(define (message-digest-update-char md ch)
  (check-message-digest 'message-digest-update-char md)
  (check-char 'message-digest-update-char ch)
  (*message-digest-update-string md (string ch)) )

(define (message-digest-update-u8 md n)
  (check-message-digest 'message-digest-update-u8 md)
  (check-integer 'message-digest-update-u8 n)
  (*message-digest-update-blob md (u8vector->blob/shared (u8vector (fxand n #xff)))) )

(define (*message-digest-update-u64 loc md n endian bytecnt)
  (check-message-digest loc md)
  (check-integer loc n)
  (*message-digest-update-blob
    md
    (u8vector->blob/shared
      (let ((u8vec (make-u8vector bytecnt)))
        (case endian
          ((big-endian be)    (u64->u8vector! u8vec n (sub1 bytecnt) -1 -1) )
          ((little-endian le) (u64->u8vector! u8vec n 0 bytecnt 1) )
          (else
            (error-byte-order loc endian) ) )
        u8vec))) )

(define (message-digest-update-u16 md n #!optional (endian (machine-byte-order)))
  (*message-digest-update-u64 'message-digest-update-u16 md n endian 2) )
(define (message-digest-update-u16-be md n)
  (*message-digest-update-u64 'message-digest-update-u16-be md n 'be 2) )
(define (message-digest-update-u16-le md n)
  (*message-digest-update-u64 'message-digest-update-u16-le md n 'le 2) )

(define (message-digest-update-u32 md n #!optional (endian (machine-byte-order)))
  (*message-digest-update-u64 'message-digest-update-u32 md n endian 4) )
(define (message-digest-update-u32-be md n)
  (*message-digest-update-u64 'message-digest-update-u32-be md n 'be 4) )
(define (message-digest-update-u32-le md n)
  (*message-digest-update-u64 'message-digest-update-u32-le md n 'le 4) )

(define (message-digest-update-u64 md n #!optional (endian (machine-byte-order)))
  (*message-digest-update-u64 'message-digest-update-u64 md n endian 8) )
(define (message-digest-update-u64-be md n)
  (*message-digest-update-u64 'message-digest-update-u64-be md n 'be 8) )
(define (message-digest-update-u64-le md n)
  (*message-digest-update-u64 'message-digest-update-u64-le md n 'le 8) )

(define (message-digest-update-procedure md src)
  (check-message-digest 'message-digest-update-procedure md)
  (check-procedure 'message-digest-update-procedure src)
  (let ((mdp (message-digest-algorithm md))
        (ctx (message-digest-context md)) )
    (do-procedure-update
      'message-digest-update-procedure
      ctx src (message-digest-primitive-update mdp)) ) )

(define (message-digest-update-port md src)
  (check-message-digest 'message-digest-update-port md)
  (check-input-port 'message-digest-update-port src)
  (let ((mdp (message-digest-algorithm md))
        (ctx (message-digest-context md)) )
    (do-procedure-update
      'message-digest-update-port
      ctx (chunk-reader-for-source src) (message-digest-primitive-update mdp)) ) )

(define (message-digest-update-file md src)
  (check-message-digest 'message-digest-update-file md)
  (check-string 'message-digest-update-file src)
  (let ((in (open-input-file src)))
    (handle-exceptions exn
        (begin (close-input-port in) (abort exn))
      (let ((mdp (message-digest-algorithm md))
            (ctx (message-digest-context md)) )
        (do-procedure-update
          'message-digest-update-port
          ctx (default-chunk-read-maker in) (message-digest-primitive-update mdp)) ) )
    (close-input-port in) ) )

;;; Till completion API

(define (message-digest-object mdp src #!optional (result-type 'hex))
  (let ((md (initialize-message-digest mdp)))
    (message-digest-update-object md src)
    (finalize-message-digest md result-type) ) )

(define (message-digest-string mdp src #!optional (result-type 'hex))
  (let ((md (initialize-message-digest mdp)))
    (message-digest-update-string md src)
    (finalize-message-digest md result-type) ) )

(define (message-digest-blob mdp src #!optional (result-type 'hex))
  (let ((md (initialize-message-digest mdp)))
    (message-digest-update-blob md src)
    (finalize-message-digest md result-type) ) )

(define (message-digest-u8vector mdp src #!optional (result-type 'hex))
  (let ((md (initialize-message-digest mdp)))
    (message-digest-update-u8vector md src)
    (finalize-message-digest md result-type) ) )

(define (message-digest-file mdp src #!optional (result-type 'hex))
  (let ((md (initialize-message-digest mdp)))
    (message-digest-update-file md src)
    (finalize-message-digest md result-type) ) )

;;; Old API

;;

(define (message-digest-primitive-apply mdp src . args) ;DEPRECATED
  (message-digest-object mdp src 'string) )

;;

(define (make-binary-message-digest src ctx-info digest-len init update final
                                    #!optional (name 'make-binary-message-digest)) ;DEPRECATED
  (message-digest-object
    (make-message-digest-primitive ctx-info digest-len init update final name)
    src
    'string) )

;;

(define (make-message-digest src ctx-info digest-len init update final
                             #!optional (name 'make-message-digest)) ;DEPRECATED
  (message-digest-object
    (make-message-digest-primitive ctx-info digest-len init update final name)
    src
    'hex) )

) ;module message-digest