source: project/release/4/message-digest/trunk/message-digest-type.scm @ 35338

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

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

(module message-digest-type

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

(import scheme chicken)
(use
  (only lolevel allocate free number-of-bytes)
  (only srfi-4 blob->u8vector/shared u8vector-length u8vector?)
  (only blob-hexadecimal blob->hex)
  (only string-hexadecimal string->hex)
  (only type-checks
    define-check+error-type)
  (only type-errors
    error-argument-type)
  miscmacros
  message-digest-primitive
  typed-define)

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

;;; Support

(define-constant MINIMUM-BUFFER-SIZE 8)

#; ;CHICKEN 4.8.0.5 has an issue here
(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) )

;perform any conversion necessary for final result representation
;assumes blob 'res' may not be of result size
#;
(define (get-result-form loc res rt len)
  (case rt
    ((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 rt) ) ) )

;perform any conversion necessary for final result representation
;assumes blob 'res' is of result size
(define (get-result-form loc res rt)
  (case (canonical-result-name rt)
    ((blob)           res )
    ((byte-string)    (blob->string res) )
    ((hex-string)     (blob->hex res) )
    ((u8vector)       (blob->u8vector/shared res) )
    (else
      (error-result-form loc rt) ) ) )

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

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

;;

(define-parameter message-digest-result-form #;DEFAULT-RESULT-TYPE 'hex-string
  (lambda (x)
    (or
      (if x
        (canonical-result-name x)
        (begin
          (warning 'message-digest-result-form "invalid result-form" x)
          (message-digest-result-form) ) ) ) ) )

;;

(define-type srfi4vector (or u8vector s8vector u16vector s16vector u32vector s32vector f32vector f64vector))

;(define-type message-digest-buffer (or string blob srfi4vector procedure input-port pointer))
(define-type message-digest-buffer (or string blob u8vector))

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

(define-type message-digest-context (or fixnum procedure))

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

(define:-record-type message-digest
  (*make-message-digest mdp ctx buf)
  message-digest?
  (mdp message-digest-primitive message-digest-algorithm)
  (ctx message-digest-context message-digest-context)
  (buf (or boolean message-digest-buffer) message-digest-buffer message-digest-buffer-set!) )

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

;;

(define: (get-message-digest-primitive-context (mdp message-digest-primitive)) -> *
  (let (
    (ctx-info (message-digest-primitive-context-info mdp)) )
    (if (procedure? ctx-info)
      (ctx-info)
      (set-finalizer! (allocate ctx-info) free) ) ) )

;;

(define: (initialize-message-digest (mdp message-digest-primitive)) -> message-digest
  (let (
    (ctx
      (get-message-digest-primitive-context
        (check-message-digest-primitive 'initialize-message-digest mdp))))
    ((message-digest-primitive-init mdp) ctx)
    (*make-message-digest mdp ctx #f) ) )

;;

(define: (finalize-message-digest (md message-digest) . (opts (list-of message-digest-result-form))) -> message-digest-result-form
  (let* (
    (result-type
      (optional opts (message-digest-result-form)))
    (mdp
      (message-digest-algorithm (check-message-digest 'finalize-message-digest md)))
    (res
      (make-blob (message-digest-primitive-digest-length mdp))) )
    ;side-effects res
    ((message-digest-primitive-final mdp) (message-digest-context md) res)
    (get-result-form 'finalize-message-digest res result-type) ) )

(define: (finalize-message-digest! (md message-digest) (result-buffer message-digest-buffer)) -> message-digest-result-form
  (let* (
    (mdp
      (message-digest-algorithm (check-message-digest 'finalize-message-digest md)))
    (res
      (check-result-type 'finalize-message-digest mdp result-buffer)) )
    ;side-effects res
    (let ((buf (if (u8vector? res) (##sys#slot res 1) res)))
      ((message-digest-primitive-final mdp) (message-digest-context md) buf) )
    res ) )

;;

(define: (setup-message-digest-buffer! (md message-digest) (sz fixnum)) -> message-digest-buffer
  (let (
    (buf (message-digest-buffer md))
    (sz (fxmax sz MINIMUM-BUFFER-SIZE)) )
    ;enough space? then reuse, otherwise new buffer
    (if buf (print "buf " buf))
    (if (and buf (fx<= sz (number-of-bytes buf)))
      buf
      (new-message-digest-buffer! md sz) ) ) )

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

;;DEPRECATED

(: message-digest-default-result-type (deprecated message-digest-result-form))
(define message-digest-default-result-type message-digest-result-form)

) ;module message-digest-type