;;;;message-digest-chunk.scm  -*- Scheme -*-
;;;;Kon Lovett, Jul '18
;;;;Kon Lovett, Aug '17  (message-digest-parameters.scm)

;;Issues
;;
;; - Use "chunk-size".
;;
;; - Uses 'context-info' to determine whether active context is "own" allocation or
;; callers. Again, a kludge.
;;
;; - Passes u8vector to update phase as a blob.

(module message-digest-chunk

(;export
  ;
  message-digest-raw-chunk
  message-digest-raw-chunk?
  message-digest-raw-chunk-object
  message-digest-raw-chunk-size message-digest-raw-chunk-start
  ;
  message-digest-chunk-size
  message-digest-chunk-port-read-maker
  message-digest-chunk-fileno-read-maker
  message-digest-chunk-converter)

(import scheme
  (chicken base)
  (chicken foreign)
  (only (chicken file posix) file-size)
  (chicken type)
  (only (srfi 4) u8vector->blob/shared subu8vector read-u8vector! make-u8vector))

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

(: message-digest-raw-chunk? (* -> boolean : message-digest-raw-chunk))
(: message-digest-raw-chunk-object (message-digest-raw-chunk --> *))
(: message-digest-raw-chunk-size (message-digest-raw-chunk --> fixnum))
(: message-digest-raw-chunk-start (message-digest-raw-chunk --> fixnum))
(: message-digest-chunk-size (#!optional fixnum -> fixnum))
(: message-digest-chunk-port-read-maker (#!optional (or false procedure) -> procedure))
(: message-digest-chunk-fileno-read-maker (#!optional (or false procedure) -> procedure))
(: message-digest-chunk-converter (#!optional (or false procedure) -> (or false procedure)))

;;

(: default-chunk-port-read-maker (input-port #!rest -> procedure))
(: make-message-digest-raw-chunk (* fixnum fixnum --> message-digest-raw-chunk))
(: default-chunk-fileno-read-maker (fixnum #!rest -> procedure))
(: mapped-buffer (symbol fixnum fixnum fixnum -> pointer procedure boolean))

(define-constant DEFAULT-CHUNK-SIZE 1024)

;;; Update Phase Helpers

(define (default-chunk-port-read-maker port . opts)
  (let* ((siz (optional opts (message-digest-chunk-size)))
         (u8buf (make-u8vector siz)) )
    (define (u8subbuffer len)
      (let ((u8buf (if (= siz len) u8buf (subu8vector u8buf 0 len))))
        (u8vector->blob/shared u8buf) ) )
    (lambda ()
      (let ((len (read-u8vector! siz u8buf port)))
        (and (positive? len)
             (u8subbuffer len)) ) ) ) )

;(define-type message-digest-raw-chunk (struct message-digest-raw-chunk))
;assignment of value of type `(procedure
;message-digest-chunk#make-message-digest-raw-chunk (* * *) (struct
;message-digest-chunk#message-digest-raw-chunk))' to toplevel variable
;`message-digest-chunk#make-message-digest-raw-chunk' does not match declared
;type `(procedure message-digest-chunk#make-message-digest-raw-chunk (* fixnum
;fixnum) (struct message-digest-raw-chunk))'
;
(define-record-type message-digest-raw-chunk
  (make-message-digest-raw-chunk obj siz beg)
  message-digest-raw-chunk?
  (obj message-digest-raw-chunk-object)
  (siz message-digest-raw-chunk-size message-digest-raw-chunk-size-set!)
  (beg message-digest-raw-chunk-start) )

(cond-expand
  ((or windows unix)
    (define (mapped-buffer loc fd siz chk)
      (import (only memory-mapped-files map-file-to-memory
                                        unmap-file-from-memory
                                        memory-mapped-file-pointer
                                        map/shared prot/read))
      ;FIXME handle lower memory situations
      (let* ((mmap (map-file-to-memory #f siz prot/read map/shared fd))
             (ptr (memory-mapped-file-pointer mmap))
        (finalize (cut unmap-file-from-memory mmap)) )
        (values ptr finalize #f) ) ) )
  (else
    ;tested w/ macosx (replaced mmap version)
    (define (mapped-buffer loc fd siz chk)
      (import (only (chicken memory) allocate free))
      (define read-into-buffer
        (foreign-lambda* bool ((int fd) (c-pointer buffer) (integer size))
          "return( read( fd, buffer, size ) == size );") )
      (let* ((ptr (allocate chk))
             (finalize (cut free ptr))
             ;FIXME assumes offset is 0
             ;FIXME pass fd in message-digest-raw-chunk?
             (updater
               (let ((rem siz))
                 (lambda (chunk)
                   (define (reader amt)
                     (let ((ptr (message-digest-raw-chunk-object chunk)))
                       (unless (read-into-buffer fd ptr amt)
                         (finalize)
                         (message-digest-raw-chunk-size-set! chunk 0)
                         ;FIXME pkg the underlying C error
                         (error loc "problem reading fileno" fd) ) )
                     (message-digest-raw-chunk-size-set! chunk amt)
                     (set! rem (- rem amt))
                     #t )
                   (cond ((zero? rem)
                           #f )
                         ((< (message-digest-raw-chunk-size chunk) rem)
                           (reader (message-digest-raw-chunk-size chunk)) )
                         (else
                           (reader rem) ) ) ) ) ) )
        (values ptr finalize updater) ) ) ) )

(define (default-chunk-fileno-read-maker fd . opts)
  (let-optionals* opts ((siz (file-size fd))
                        (chk (message-digest-chunk-size)) )
    ;anything to read?
    (if (zero? siz)
        ;then always nothing
        (constantly #f)
        ;else return chunk, after reading, or #f
        ;errors when lolevel problem
        (let-values (((buffer cleanup updater)
                        (mapped-buffer 'default-chunk-fileno-read-maker fd siz chk)) )
          (let ((chunk (and buffer (make-message-digest-raw-chunk buffer chk 0))))
            ;NOTE buffer used as flag
            (define (finishup)
              (set! buffer #f)
              (cleanup)
              #f )
            ;no updater means 1) chunk already filled, & 2) last read done
            (if (not updater)
                (lambda ()
                  (if buffer
                      (begin
                        (set! buffer #f)
                        (message-digest-raw-chunk-size-set! chunk siz)
                        chunk )
                      (finishup) ) )
                (lambda ()
                  (and buffer
                       (if (updater chunk) chunk (finishup))) ) ) ) ) ) ) )

;; Message Digest "chunk"

;;

(define message-digest-chunk-size
  (make-parameter DEFAULT-CHUNK-SIZE
    (lambda (x)
      (cond ((positive? x) x)
            ((not x) DEFAULT-CHUNK-SIZE)
            (else
              (warning 'message-digest-chunk-size "invalid positive-fixnum" x)
              (message-digest-chunk-size) ) ) ) ) )

;;

(define message-digest-chunk-port-read-maker
  (make-parameter default-chunk-port-read-maker
    (lambda (x)
      (cond ((procedure? x) x)
            ((not x) default-chunk-port-read-maker)
            (else
              (warning 'message-digest-chunk-port-read-maker "invalid procedure" x)
              (message-digest-chunk-port-read-maker) ) ) ) ) )

;;

(define message-digest-chunk-fileno-read-maker
  (make-parameter default-chunk-fileno-read-maker
    (lambda (x)
      (cond ((procedure? x) x)
            ((not x) default-chunk-fileno-read-maker)
            (else
              (warning 'message-digest-chunk-fileno-read-maker "invalid procedure" x)
              (message-digest-chunk-fileno-read-maker) ) ) ) ) )

;;

(define message-digest-chunk-converter
  (make-parameter #f
    (lambda (x)
      (if (or (not x) (procedure? x)) x
          (begin
            (warning 'message-digest-chunk-converter "invalid procedure or #f" x)
            (message-digest-chunk-converter) ) ) ) ) )

;;;

;FIXME name sucks
;(: message-digest-chunk-port-read-maker (deprecated message-digest-chunk-port-reader))
;(: message-digest-chunk-fileno-read-maker (deprecated message-digest-chunk-fileno-reader))

) ;module message-digest-chunk