;;;; message-digest-primitive.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
;;
;; - see tiger-hash , sha2 , sha1 , ripemd , md5 , hashes
;;
;; - synthesize raw-update from update

(module message-digest-primitive

(;export
  ;
  make-message-digest-primitive-context
  ; Algorithm API
  make-message-digest-primitive
  message-digest-primitive? check-message-digest-primitive error-message-digest-primitive
  message-digest-primitive-name
  message-digest-primitive-block-length
  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-raw-update)

(import scheme
  (chicken base)
  (chicken fixnum)
  (chicken gc)
  (chicken type)
  (only (chicken memory) allocate free)
  (only type-checks define-check+error-type check-positive-fixnum check-procedure)
  (only type-errors error-argument-type))

;;; Support

;;

(define (positive-fixnum? obj)
  (and (fixnum? obj) (positive? obj)) )

(define (primitive-context-info? obj)
  (or (procedure? obj) (positive-fixnum? obj)) )

(define (primitive-name? obj)
  (or (symbol? obj) (string? obj)) )

;;; Message Digest Algorithm API

;;

(define-type message-digest-primitive-name (or symbol string))

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

(define-type message-digest-primitive-raw-update (or boolean procedure))

(define-type message-digest-primitive (struct message-digest-primitive))
;assignment of value of type `(procedure message-digest-primitive#*make-message-digest-primitive (* * * * * * * *) (struct message-digest-primitive#message-digest-primitive))' to toplevel variable `message-digest-primitive#*make-message-digest-primitive' does not match declared type `(procedure message-digest-primitive#*make-message-digest-primitive ((or fixnum procedure) fixnum procedure procedure procedure fixnum (or symbol string) (or boolean procedure)) (struct message-digest-primitive))'
(: *make-message-digest-primitive (message-digest-primitive-context-info fixnum procedure procedure procedure fixnum message-digest-primitive-name message-digest-primitive-raw-update --> message-digest-primitive))
(: message-digest-primitive? (* -> boolean : message-digest-primitive))
(: message-digest-primitive-context-info (message-digest-primitive --> message-digest-primitive-context-info))
(: message-digest-primitive-digest-length (message-digest-primitive --> fixnum))
(: message-digest-primitive-init (message-digest-primitive --> procedure))
(: message-digest-primitive-update (message-digest-primitive --> procedure))
(: message-digest-primitive-final (message-digest-primitive --> procedure))
(: message-digest-primitive-block-length (message-digest-primitive --> fixnum))
(: message-digest-primitive-name (message-digest-primitive --> message-digest-primitive-name))
(: message-digest-primitive-raw-update (message-digest-primitive --> message-digest-primitive-raw-update))
;
(define-record-type message-digest-primitive
  (*make-message-digest-primitive ctxi digest-len init update final block-len name raw-update)
  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)
  (block-len message-digest-primitive-block-length)
  (name message-digest-primitive-name)
  (raw-update message-digest-primitive-raw-update) )

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

;;

(define-inline (check-message-digest-arguments loc ctx-info digest-len init update final block-len name raw-update)
  (unless (primitive-context-info? ctx-info)
    (error-argument-type loc ctx-info "positive-fixnum or procedure" 'context-info) )
  (check-positive-fixnum loc digest-len 'digest-length)
  (check-procedure loc init 'digest-initializer)
  (check-procedure loc update 'digest-updater)
  (check-procedure loc final 'digest-finalizer)
  (check-positive-fixnum loc block-len 'block-length)
  (unless (primitive-name? name)
    (error-argument-type loc name "symbol or string" 'name) )
  (when raw-update
    (check-procedure loc raw-update 'digest-raw-updater) ) )

;;

;assignment of value of type `(procedure message-digest-primitive#make-message-digest-primitive (* * * * * #!rest) (struct message-digest-primitive#message-digest-primitive))' to toplevel variable `message-digest-primitive#make-message-digest-primitive' does not match declared type `(procedure message-digest-primitive#make-message-digest-primitive ((or fixnum procedure) fixnum procedure procedure procedure #!rest *) (struct message-digest-primitive))'
(: make-message-digest-primitive (message-digest-primitive-context-info fixnum procedure procedure procedure #!rest -> message-digest-primitive))
;
(define (make-message-digest-primitive ctx-info digest-len init update final
            #!key (block-length 4) (name (gensym 'mdp)) (raw-update #f))
  (check-message-digest-arguments 'make-message-digest-primitive
    ctx-info digest-len init update final
    block-length name raw-update)
  (*make-message-digest-primitive
    ctx-info digest-len init update final
    block-length name raw-update) )

;;

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

) ;module message-digest-primitive