;;;; message-digest-byte-vector.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
;;
;; - blob has byte index but string has character index!

(module message-digest-byte-vector

(;export
  ;
  message-digest-update-blob
  message-digest-update-string
  ;
  message-digest-blob
  message-digest-string
  message-digest-blob!
  message-digest-string!)

(import scheme
  (chicken base)
  (chicken blob)
  (chicken type)
  (only (srfi 13) substring/shared)
  (only (check-errors sys) check-blob check-string)
  (only (type-checks-numbers fixnum) check-natural-fixnum)
  (only (type-checks-numbers interval) check-range)
  message-digest-primitive
  message-digest-type
  message-digest-support)

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

(: message-digest-update-blob (message-digest blob #!optional fixnum fixnum -> void))
(: message-digest-update-string (message-digest string #!optional fixnum fixnum -> void))

(: message-digest-blob (message-digest-kind blob #!optional message-digest-result-form fixnum fixnum -> message-digest-result-type))
(: message-digest-string (message-digest-kind string #!optional message-digest-result-form fixnum fixnum -> message-digest-result-type))

(: message-digest-blob! (message-digest-kind blob message-digest-buffer #!optional message-digest-result-form fixnum fixnum -> message-digest-result-type))
(: message-digest-string! (message-digest-kind string message-digest-buffer #!optional message-digest-result-form fixnum fixnum -> message-digest-result-type))

;;

(define (check-fixnum-range loc start end)
  ;FIXME chicken does not like dropping a multi-valued result on the floor
  (receive
    (check-range loc
      (check-natural-fixnum loc start 'start)
      (check-natural-fixnum loc end 'end)
      "end < start")) )

;;; Message Digest API

;; Update

;;

;FIXME using & then checking !

(define (message-digest-update-blob md blb . opts)
  (let-optionals* opts ((start 0)
                        (end (blob-size (check-blob 'message-digest-update-blob blb))) )
    (check-fixnum-range 'message-digest-update-blob start end)
    (*message-digest-update-blob
      (check-message-digest 'message-digest-update-blob md)
      (blob/slice blb start end)) ) )

;;

(define (message-digest-update-string md str . opts)
  (let-optionals* opts ((start 0)
                        (end (string-length (check-string 'message-digest-update-string str))) )
    (check-fixnum-range 'message-digest-update-string start end)
    (*message-digest-update-string
      (check-message-digest 'message-digest-update-string md)
      (string/slice str start end)) ) )

;;

;; Single Source API

(define (message-digest-blob mdk blb . opts)
  (let-optionals* opts ((restyp (message-digest-result-form))
                        (start 0)
                        (end (blob-size (check-blob 'message-digest-blob blb))) )
    (let ((md (initialized-message-digest mdk)))
      (check-fixnum-range 'message-digest-blob start end)
      (message-digest-update-blob md blb start end)
      (finalize-message-digest md restyp) ) ) )

(define (message-digest-string mdk str . opts)
  (let-optionals* opts ((restyp (message-digest-result-form))
                        (start 0)
                        (end (string-length (check-string 'message-digest-string str))) )
    (let ((md (initialized-message-digest mdk)))
      (check-fixnum-range 'message-digest-string start end)
      (message-digest-update-string md str start end)
      (finalize-message-digest md restyp) ) ) )

(define (message-digest-blob! mdk blb buf . opts)
  (let-optionals* opts ((start 0)
                        (end (blob-size (check-blob 'message-digest-blob! blb))) )
    (let ((md (initialized-message-digest mdk)))
      (check-fixnum-range 'message-digest-blob! start end)
      (message-digest-update-blob md blb start end)
      (finalize-message-digest! md buf) ) ) )

(define (message-digest-string! mdk str buf . opts)
  (let-optionals* opts ((start 0)
                        (end (string-length (check-string 'message-digest-string! str))) )
    (let ((md (initialized-message-digest mdk)))
      (check-fixnum-range 'message-digest-string! start end)
      (message-digest-update-string md str start end)
      (finalize-message-digest! md buf) ) ) )

) ;module message-digest-byte-vector