;;;; message-digest-type.scm  -*- Scheme -*-
;;;; 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.

(declare
  (bound-to-procedure ##sys#slot) )

(module message-digest-type

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

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

;;; Support

;;

(define-type message-digest-result-form symbol)

(define-type message-digest-result-type (or string blob u8vector))

#; ;desired, bufpointer is (pointer + length)
(define-type message-digest-buffer (or string blob srfi4vector procedure input-port bufpointer))
(define-type message-digest-buffer (or string blob u8vector))

(define-type message-digest-primitive (struct message-digest-primitive))

(define-type message-digest-primitive-context *)

(define-type message-digest (struct message-digest))

;;

(define (%u8vector-blob u8vec) (##sys#slot u8vec 1))

;;

(define-constant MINIMUM-BUFFER-SIZE 8)

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

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

(: canonical-result-name (message-digest-result-form -> (or boolean message-digest-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

(: get-result-form (symbol blob message-digest-result-form -> message-digest-result-type))
;
(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) ) ) )

#; ;assumes blob 'res' may not be of result size
(define: ((get-result-form message-digest-result-type) (loc symbol) (res blob) (restyp message-digest-result-form))
;(define:-pure ((func rettype) ,,,) ...)
;(define: (proc ,,,) ...) == (define: ((proc void) ,,,) ...)
  (case restyp
    ((blob)
      (if (fx= len (blob-size res))
        res
        (string->blob (substring (blob->string res) 0 len)) ) )
    ((byte-string string)
      (let ((str (blob->string res)))
        (if (fx= len (string-length str))
          str
          (substring str 0 len) ) ) )
    ((hex-string hex hexstring)
      (blob->hex res 0 len) )
    ((u8vector)
      (let ((vec (blob->u8vector/shared res)))
        (if (fx= len (u8vector-length vec))
          vec
          (subu8vector vec 0 len) ) ) )
    (else
      (error-result-form loc restyp) ) ) )

(: check-result-type (symbol message-digest-primitive message-digest-result-type -> message-digest-result-type))
;
(define-inline (check-result-type loc mdp obj)
  (let (
    (siz
      (cond
        ((string? obj)    (string-length obj))
        ((blob? obj)      (blob-size obj))
        ((u8vector? obj)  (u8vector-length obj))
        (else
          (error loc "unsupported result buffer" obj) ) ) )
    (rqr
      (message-digest-primitive-digest-length mdp)) )
    (unless (<= rqr siz)
      (error loc "result buffer too small" rqr obj) ) )
  obj )

;;; Message Digest API

;;

(: message-digest-result-form (#!optional message-digest-result-form -> message-digest-result-form))
;
(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) ) ) ) ) )

;;

(: *make-message-digest (message-digest-primitive message-digest-primitive-context (or boolean 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 boolean message-digest-buffer)))
(: message-digest-buffer-set! (message-digest (or boolean message-digest-buffer) -> void))
;
(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

(: new-message-digest-buffer (message-digest fixnum -> message-digest-buffer))
;
(define-inline (new-message-digest-buffer md siz)
  (let ((buf (make-blob siz)))
    (message-digest-buffer-set! md buf)
    buf ) )

(: new-message-digest (message-digest-primitive message-digest-primitive-context -> message-digest))
;
(define-inline (new-message-digest mdp ctx)
  ((message-digest-primitive-init mdp) ctx)
  (*make-message-digest mdp ctx #f) )

(: *finalize-message-digest (message-digest-buffer message-digest message-digest-primitive -> message-digest-buffer))
;
(define-inline (*finalize-message-digest res md mdp)
  ;side-effects res
  (let ((buf (if (u8vector? res) (%u8vector-blob res) res)))
    ((message-digest-primitive-final mdp) (message-digest-context md) buf) )
  res )

;;

(: initialize-message-digest (message-digest-primitive -> message-digest))
;
(define (initialize-message-digest mdp)
  ;(check-message-digest-primitive 'initialize-message-digest mdp)
  (new-message-digest mdp (make-message-digest-primitive-context mdp)) )

(: initialize-message-digest! (message-digest-primitive message-digest-primitive-context -> message-digest))
;
(define (initialize-message-digest! mdp ctx)
  (new-message-digest (check-message-digest-primitive 'initialize-message-digest! mdp) ctx) )

;;

(: ensure-message-digest-buffer! (message-digest fixnum -> message-digest-buffer))
;
(define (ensure-message-digest-buffer! md siz)
  (let (
    (siz
      (fxmax (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 (fx<= siz (number-of-bytes buf)))
      buf
      (new-message-digest-buffer md siz) ) ) )

;;

(: finalize-message-digest (message-digest #!optional message-digest-result-form -> message-digest-result-type))
;
(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-blob (message-digest-primitive-digest-length mdp))) )
    (*finalize-message-digest res md mdp)
    (get-result-form 'finalize-message-digest res restyp) ) )

(: finalize-message-digest! (message-digest message-digest-buffer -> message-digest-result-type))
;
(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) ) )

) ;module message-digest-type