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

(module message-digest-primitive

(;export
  ;
  message-digest-primitive
  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)
(import (chicken base))
(import (chicken fixnum))
(import (chicken gc))
(import (chicken type))
(import (chicken foreign))
(import (only (chicken memory) allocate free))
(import (only type-checks-basic define-check+error-type))
(import (only type-errors-basic error-argument-type))
(import (only type-checks-structured check-procedure))
(import (only (type-checks-numbers fixnum) check-positive-fixnum))

(include-relative "message-digest-primitive.types")

(define-type raw-data (not immediate))

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

(define-type context-info (or fixnum procedure))

(define-type init-procedure (raw-data -> *))
(define-type update-procedure (raw-data raw-data fixnum -> *))
(define-type final-procedure (raw-data raw-data -> *))

(: make-message-digest-primitive (context-info fixnum
                                  init-procedure
                                  (or false update-procedure)
                                  final-procedure
                                  #!key (block-length fixnum)
                                        (name (or symbol string))
                                        (raw-update (or false update-procedure))
                                  -> message-digest-primitive))

(: message-digest-primitive? (* -> boolean : message-digest-primitive))

(: message-digest-primitive-context-info (message-digest-primitive --> context-info))
(: message-digest-primitive-digest-length (message-digest-primitive --> fixnum))

(: message-digest-primitive-init (message-digest-primitive --> init-procedure))
(: message-digest-primitive-update (message-digest-primitive --> update-procedure))
(: message-digest-primitive-final (message-digest-primitive --> final-procedure))

(: message-digest-primitive-block-length (message-digest-primitive --> fixnum))
(: message-digest-primitive-name (message-digest-primitive --> primitive-name))
(: message-digest-primitive-raw-update (message-digest-primitive --> (or false update-procedure)))

(: make-message-digest-primitive-context (message-digest-primitive -> message-digest-primitive-context))

;

(: *make-message-digest-primitive (context-info fixnum
                                   init-procedure update-procedure final-procedure
                                   fixnum primitive-name (or false update-procedure)
                                   -> message-digest-primitive))

(: scheme-object-data-pointer (raw-data -> pointer))
(: make-scheme-object-updater (update-procedure -> update-procedure))

;;

(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

;;

;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))'

(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 (error-primitive-context-info loc obj #!optional nam)
  (error-argument-type loc obj "positive-fixnum or procedure" nam) )

(define (check-primitive-context-info loc obj #!optional nam)
  (unless (primitive-context-info? obj) (error-primitive-context-info loc obj nam))
  obj )

;

(define (error-primitive-name loc obj #!optional nam)
  (error-argument-type loc obj "symbol or string" nam) )

(define (check-primitive-name loc obj #!optional nam)
  (unless (primitive-name? obj) (error-primitive-name loc obj nam))
  obj )

;;

(define scheme-object-data-pointer
  (foreign-lambda* c-pointer ((nonnull-scheme-pointer psrc)) "return( psrc );"))

(define ((make-scheme-object-updater raw-update) ctx-info obj len)
  (raw-update ctx-info (scheme-object-data-pointer obj) len) )

(define (ensure-update loc update raw-update)
  (let ((update (or update (and raw-update (make-scheme-object-updater raw-update)))))
    ;we know about raw -> cooked
    (unless update (error loc "missing update & raw-update procedures"))
    update ) )

;;

;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))'
;
(define (make-message-digest-primitive ctx-info digest-len init update final
                                       #!key (block-length 4)
                                             (name (gensym 'mdp))
                                             (raw-update #f))
  (*make-message-digest-primitive
    (check-primitive-context-info 'make-message-digest-primitive ctx-info 'context-info)
    (check-positive-fixnum 'make-message-digest-primitive digest-len 'digest-length)
    (check-procedure 'make-message-digest-primitive init 'digest-initializer)
    (ensure-update 'make-message-digest-primitive
      (and update
           (check-procedure 'make-message-digest-primitive update 'digest-updater))
      (and raw-update
           (check-procedure 'make-message-digest-primitive raw-update 'digest-raw-updater)))
    (check-procedure 'make-message-digest-primitive final 'digest-finalizer)
    (check-positive-fixnum 'make-message-digest-primitive block-length 'block-length)
    (check-primitive-name 'make-message-digest-primitive name 'name)
    raw-update) )

;;

(define (make-message-digest-primitive-context mdp)
  (let ((ctx-info (message-digest-primitive-context-info
                    (check-message-digest-primitive 'make-message-digest-primitive-context mdp))) )
    (if (procedure? ctx-info) (ctx-info)
        (set-finalizer! (allocate ctx-info) free) ) ) )

) ;module message-digest-primitive