;;;; message-digest-update-item.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)

(module message-digest-update-item

(;export
  message-digest-update-object
  message-digest-update-procedure
  message-digest-update-port
  message-digest-update-file)

(import scheme
  (chicken file)
  (chicken base)
  (chicken blob)
  (only (chicken memory representation) number-of-bytes)
  (only (chicken memory) pointer?)
  (chicken type)
  (only (chicken file posix) file-open file-close open/rdonly directory?)
  message-digest-primitive
  message-digest-type
  message-digest-chunk
  message-digest-support
  type-checks
  type-errors)

;;; Support

;;

(include "message-digest-types")

;;

(define-type converted-chunk (or blob string message-digest-raw-chunk))

(define-type start-index fixnum)
(define-type end-index (or boolean fixnum))

(define-type source-update procedure)
(define-type raw-update procedure)

;;

;=> #f or converted-chunk
(: chunk-convert (* -> converted-chunk))
;
(define (chunk-convert obj)
  (and-let* (
    (cnv (message-digest-chunk-converter)) )
    (cnv obj) ) )

(: get-port-chunk-reader (input-port -> procedure))
;
(define (get-port-chunk-reader port)
  ((message-digest-chunk-port-read-maker) port) )

(: get-fileno-chunk-reader (fixnum -> procedure))
;
(define (get-fileno-chunk-reader fd)
  ((message-digest-chunk-fileno-read-maker) fd) )

(: get-update (message-digest --> source-update))
;
(define (get-update md)
  (message-digest-primitive-update (message-digest-algorithm md)) )

(: get-raw-update (message-digest --> raw-update))
;
(define (get-raw-update md)
  (message-digest-primitive-raw-update (message-digest-algorithm md)) )

;;

(: do-object-update (symbol message-digest * start-index end-index -> void))
;
(define (do-object-update loc md src start end)
  (cond
    ((input-port? src)    (do-port-update loc md src start end) )
    ((procedure? src)     (do-procedure-update loc md src start end) )
    (else                 (do-bytes-update loc md src start end) ) ) )

(: do-port-update (symbol message-digest input-port start-index end-index -> void))
;
(define (do-port-update loc md port start end)
  (do-procedure-update loc md (get-port-chunk-reader port) start end) )

(: do-procedure-update (symbol message-digest procedure start-index end-index -> void))
;
(define (do-procedure-update loc md proc start end)
  (let (
    (src-updt (get-update md))
    (raw-updt (get-raw-update md))
    (ctx (message-digest-context md)) )
    ;note the 'src' object (return of proc) may or may not be unique!
    (let loop ()
      (and-let* ((dat (proc)))
        (*do-bytes-update loc ctx dat src-updt raw-updt start end)
        (loop) ) )
    ;do not return #f
    (void) ) )

(: do-bytes-update (symbol message-digest * start-index end-index -> void))
;
(define (do-bytes-update loc md src start end)
  (*do-bytes-update
    loc
    (message-digest-context md)
    src
    (get-update md)
    (get-raw-update md)
    start end) )

(: *do-bytes-update (symbol message-digest-primitive-context * source-update raw-update start-index end-index -> void))
;
(define (*do-bytes-update loc ctx src src-updt raw-updt start end)
  (cond
    ;simple bytes
    ((blob? src)
      (let (
        (blb (blob/slice src start end)))
        (src-updt ctx blb (blob-size blb))) )
    ((string? src)
      (let (
        (str (string/slice src start end)))
        (src-updt ctx str (string-length str))) )
    ((message-digest-raw-chunk? src)
      (let* (
        (obj (message-digest-raw-chunk-object src))
        (updater (if (pointer? obj) raw-updt src-updt)) )
        (unless updater
          ;FIXME doesn't know which md primitive is providing the updater
          (error loc "primitive does not support raw-update") )
        ;FIXME xtra arg (message-digest-raw-chunk-start src)
        (updater ctx obj (message-digest-raw-chunk-size src)) ) )
    ;more complicated bytes
    ((object->bytevector-like src)
      => (cut *do-bytes-update loc ctx <> src-updt raw-updt start end) )
    ;too complicated bytes
    (else
      (signal-type-error loc "indigestible object" src start end) ) ) )

(: object->bytevector-like (* -> converted-chunk))
;
(define (object->bytevector-like obj)
  (or
    (packed-vector->blob/shared obj)
    (chunk-convert obj)) )

;;

(: *message-digest-update-file/fileno (symbol message-digest pathname -> void))
;
(define (*message-digest-update-file/fileno loc md flnm)
  (let ((fd #f))
    (dynamic-wind
      (lambda () (set! fd (file-open flnm open/rdonly)) )
      (lambda () (do-procedure-update loc md (get-fileno-chunk-reader fd) 0 #f) )
      (lambda () (file-close fd) ) ) )
  #; ;porta-potty
  (let (
    (fd (file-open flnm open/rdonly)) )
    (handle-exceptions exn
        (begin
          (file-close fd)
          (abort exn) )
      (do-procedure-update loc md (get-fileno-chunk-reader fd) 0 #f) )
    (file-close fd) ) )

(: *message-digest-update-file/port (symbol message-digest pathname -> void))
;
(define (*message-digest-update-file/port loc md flnm)
  (let ((in #f))
    (dynamic-wind
      (lambda () (set! in (open-input-file flnm)) )
      (lambda () (do-port-update loc md in 0 #f) )
      (lambda () (close-input-port in) ) ) )
  #; ;porta-potty
  (let (
    (in (open-input-file flnm)) )
    (handle-exceptions exn
        (begin
          (close-input-port in)
          (abort exn) )
      (do-port-update loc md in 0 #f) )
    (close-input-port in) ) )

;;; Update Operation

;;

(: message-digest-update-object (message-digest * #!rest -> void))
;
(define (message-digest-update-object md obj . opts)
  (let-optionals* opts (
    (start 0)
    (end #f) )
    (do-object-update
      'message-digest-update-object
      (check-message-digest 'message-digest-update-object md)
      obj
      start end) ) )

;;

(: message-digest-update-procedure (message-digest procedure -> void))
;
(define (message-digest-update-procedure md proc)
  (do-procedure-update
    'message-digest-update-procedure
    (check-message-digest 'message-digest-update-procedure md)
    (check-procedure 'message-digest-update-procedure proc)
    0 #f) )

;;

(: message-digest-update-port (message-digest input-port -> void))
;
(define (message-digest-update-port md port)
  (do-port-update
    'message-digest-update-port
    (check-message-digest 'message-digest-update-port md)
    (check-input-port 'message-digest-update-port port)
    0 #f) )

;;

(: message-digest-update-file (message-digest pathname -> void))
;
(define (message-digest-update-file md flnm)
  ;
  (unless (file-exists? (check-string 'message-digest-update-file flnm))
    (error 'message-digest-update-file "no such file" flnm) )
  ;
  #; ;can't open a directory?
  (when (directory? flnm)
    (error 'message-digest-update-file "file is a directory" flnm) )
  ;
  (if (get-raw-update (check-message-digest 'message-digest-update-file md))
    (*message-digest-update-file/fileno 'message-digest-update-file md flnm)
    (*message-digest-update-file/port 'message-digest-update-file md flnm) ) )

) ;module message-digest-update-item