;;;; message-digest-type.scm  -*- Scheme -*-
;;;; Kon Lovett, Apr '20
;;;; Kon Lovett, Jul '18
;;;; Kon Lovett, Aug '17
;;;; Kon Lovett, Apr '12
;;;; Kon Lovett, May '10 (message-digest.scm)
;;;; Kon Lovett, Jan '06 (message-digest.scm)

;; Issues
;;
;; - Uses 'context-info' to determine whether active context is "own" allocation or
;;callers.
;;
;; - Inling does help


(module message-digest-type

(;export
  ;
  message-digest-result-form
  ;MD API
  message-digest
  message-digest? check-message-digest error-message-digest
  message-digest-algorithm message-digest-context
  ;
  ensure-message-digest-buffer!
  ;
  setup-message-digest
  reset-message-digest!
  initialized-message-digest
  finalize-message-digest finalize-message-digest!
  ;DEPRECATED
  initialize-message-digest initialize-message-digest!)

(import scheme
  (chicken base)
  (chicken type)
  (chicken blob)
  (only (chicken memory representation) number-of-bytes)
  (only (srfi 4) u8vector->blob/shared blob->u8vector/shared
                 u8vector-length u8vector? make-u8vector)
  (only blob-hexadecimal blob->hex)
  (only string-hexadecimal string->hex)
  (only type-checks-basic define-check+error-type)
  (only type-errors-basic error-argument-type)
  (only (type-checks-numbers fixnum) check-positive-fixnum)
  message-digest-primitive)

(include "message-digest-type.types")

(: message-digest-result-form (#!optional message-digest-result-form -> message-digest-result-form))

(: *make-message-digest (message-digest-primitive message-digest-primitive-context (or false message-digest-buffer) -> message-digest))
(: message-digest? (* -> boolean : message-digest))
(: message-digest-algorithm (message-digest -> message-digest-primitive))
(: message-digest-context (message-digest -> message-digest-primitive-context))
(: message-digest-buffer (message-digest -> (or false message-digest-buffer)))
(: message-digest-buffer-set! (message-digest (or false message-digest-buffer) -> void))

(: *new-message-digest-buffer! (message-digest fixnum -> message-digest-buffer))
(: *reset-message-digest! (message-digest -> message-digest))
(: *finalize-message-digest! (message-digest-buffer message-digest message-digest-primitive -> message-digest-buffer))

(: setup-message-digest (message-digest-primitive #!optional message-digest-primitive-context -> message-digest))
(: reset-message-digest! (message-digest -> message-digest))
(: initialized-message-digest (message-digest-kind -> message-digest))

(: ensure-message-digest-buffer! (message-digest fixnum -> message-digest-buffer))

(: finalize-message-digest (message-digest #!optional message-digest-result-form -> message-digest-result-type))
(: finalize-message-digest! (message-digest message-digest-buffer -> message-digest-result-type))

(: initialize-message-digest (deprecated setup-message-digest))
(: initialize-message-digest! (deprecated setup-message-digest))

;;

(: canonical-result-name (message-digest-result-form -> (or false message-digest-result-form)))
(: get-result-form (symbol blob message-digest-result-form -> message-digest-result-type))
(: check-result-type (symbol message-digest-primitive message-digest-result-type -> message-digest-result-type))

(define-constant MINIMUM-BUFFER-SIZE 8)

(define-constant DEFAULT-RESULT-TYPE 'hex-string)

(define-inline (error-result-form loc obj)
  (error-argument-type loc obj "symbol in {string hex blob u8vector}" 'result-form) )

(define-inline (canonical-result-name x)
  (case x
    ((blob)                       'blob)
    ((byte-string string)         'byte-string)
    ((hex-string hex hexstring)   'hex-string)
    ((u8vector)                   'u8vector)
    (else
      #f) ) )

;perform any conversion necessary for final result representation

(define-inline (get-result-form loc res restyp)
  (case (canonical-result-name restyp)
    ((blob)           res)
    ((byte-string)    (blob->string res))
    ((hex-string)     (blob->hex res))
    ((u8vector)       (blob->u8vector/shared res))
    (else
      (error-result-form loc restyp)) ) )

(define-inline (result-size loc obj)
  (cond ((string? obj)      (string-length obj))
        ((blob? obj)        (blob-size obj))
        ((u8vector? obj)    (u8vector-length obj))
        (else
          (error loc "unsupported result buffer" obj) ) ) )

(define-inline (check-result-type loc mdp obj)
  (let ((siz (result-size loc obj))
        (rqr (message-digest-primitive-digest-length mdp)) )
    (unless (<= rqr siz)
      (error loc "result buffer too small" rqr siz obj) ) )
  obj )

;;; Message Digest API

;;

(define message-digest-result-form
  (make-parameter DEFAULT-RESULT-TYPE
    (lambda (x)
      (cond ((not x)
              DEFAULT-RESULT-TYPE)
            ((canonical-result-name x)
              => identity)
            (else
              (warning 'message-digest-result-form "invalid result-form" x)
              (message-digest-result-form) ) ) ) ) )

;;

;
(define-record-type message-digest
  (*make-message-digest mdp ctx buf)
  message-digest?
  (mdp message-digest-algorithm)
  (ctx message-digest-context)
  (buf message-digest-buffer message-digest-buffer-set!) )

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

;; Support

(define-inline (*new-message-digest-buffer! md siz)
  ;side-effects md
  (let ((buf (make-blob siz)))
    (message-digest-buffer-set! md buf)
    buf ) )

(define-inline (*reset-message-digest! md)
  ;side-effects ctx
  ((message-digest-primitive-init (message-digest-algorithm md))
    (message-digest-context md))
  md )

(define-inline (byteblobof res)
  (if (not (u8vector? res)) res
      (u8vector->blob/shared res)) )

(define-inline (*finalize-message-digest! res md mdp)
  ;side-effects res
  ((message-digest-primitive-final mdp)
    (message-digest-context md) (byteblobof res))
  res )

(define-inline (make-result-buffer mdp)
  (make-blob (message-digest-primitive-digest-length mdp)) )

;;

(define (reset-message-digest! md)
  (*reset-message-digest! (check-message-digest 'reset-message-digest! md)) )

(define (setup-message-digest mdp #!optional ctx)
  (check-message-digest-primitive 'setup-message-digest mdp)
  (let ((ctx (or ctx (make-message-digest-primitive-context mdp))))
    (*reset-message-digest! (*make-message-digest mdp ctx #f)) ) )

(define (initialized-message-digest mdp-or-md)
  (if (message-digest? mdp-or-md)
      (*reset-message-digest! mdp-or-md)
      (setup-message-digest mdp-or-md) ) )

;;

(define (ensure-message-digest-buffer! md siz)
  (let ((siz (max (check-positive-fixnum 'ensure-message-digest-buffer! siz)
                  MINIMUM-BUFFER-SIZE))
        (buf (message-digest-buffer (check-message-digest 'ensure-message-digest-buffer! md))) )
    ;existing buffer has enough space? then reuse, otherwise new buffer
    (if (and buf (<= siz (number-of-bytes buf)))
        buf
        (*new-message-digest-buffer! md siz) ) ) )

;;

(define (finalize-message-digest md #!optional (restyp (message-digest-result-form)))
  (let* ((mdp (message-digest-algorithm (check-message-digest 'finalize-message-digest md)))
         (res (make-result-buffer mdp)) )
    (*finalize-message-digest! res md mdp)
    (get-result-form 'finalize-message-digest res restyp) ) )

(define (finalize-message-digest! md resbuf)
  (let* ((mdp (message-digest-algorithm (check-message-digest 'finalize-message-digest! md)))
         (res (check-result-type 'finalize-message-digest mdp resbuf)) )
    (*finalize-message-digest! res md mdp) ) )

;;; DEPRECATED

(define initialize-message-digest setup-message-digest)
(define initialize-message-digest! setup-message-digest)

) ;module message-digest-type