;;;;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
  ;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 fixnum)
  (chicken foreign)
  (only (chicken file posix) file-size)
  (chicken type)
  (only (srfi 4) u8vector->blob/shared subu8vector read-u8vector! make-u8vector))

;;; Support

;;fx-utils

(: fxzero? (fixnum --> boolean))
;
(define (fxzero? n) (fx= 0 n))

(: fxpositive? (fixnum --> boolean))
;
(define (fxpositive? n) (fx< 0 n))

;;

(include "message-digest-types")

;;

(define-constant DEFAULT-CHUNK-SIZE 1024)

;;; Update Phase Helpers

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

;(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))'
(: make-message-digest-raw-chunk (* fixnum fixnum --> message-digest-raw-chunk))
(: 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))
;
(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) )

(: default-chunk-fileno-read-maker (fixnum #!rest -> procedure))
;
(define (default-chunk-fileno-read-maker fd . opts)
  (let-optionals* opts (
    (siz (file-size fd))
    (chk (message-digest-chunk-size)) )
    ;anything to read?
    (if (fxzero? siz)
      (lambda () #f)
      ;returns chunk, after reading, or #f
      ;errors when lolevel problem
      (let-values (
        ;buffer used as flag
        ((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))) )
          ;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 )
                (begin
                  (cleanup)
                  #f ) ) )
            (lambda ()
              (and
                buffer
                (if (updater chunk)
                  chunk
                  (begin
                    (set! buffer #f)
                    (cleanup)
                    #f ) ) ) ) ) ) ) ) ) )

(cond-expand

  ((or windows unix)

    (import
      (only memory-mapped-files
        map-file-to-memory unmap-file-from-memory
        memory-mapped-file-pointer map/shared prot/read))

    (: mapped-buffer (symbol fixnum fixnum fixnum -> pointer procedure boolean))
    ;
    (define (mapped-buffer loc fd siz chk)
      (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)

    (import (only (chicken memory) allocate free))

    (: read-into-buffer (fixnum pointer fixnum -> boolean))
    ;
    (define read-into-buffer
      (foreign-lambda* bool ((int fd) (c-pointer buffer) (integer size))
        "C_return( read( fd, buffer, size ) == size );") )

    (: mapped-buffer (symbol fixnum fixnum fixnum -> pointer procedure boolean))
    ;
    (define (mapped-buffer loc fd siz chk)
      (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)
                    (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) ) ) ) )

;;; Message Digest "chunk"

;;

(: message-digest-chunk-size (#!optional fixnum -> fixnum))
;
(define message-digest-chunk-size (make-parameter DEFAULT-CHUNK-SIZE
  (lambda (x)
    (cond
      ((fxpositive? x)  x)
      ((not x)          DEFAULT-CHUNK-SIZE)
      (else
        (warning 'message-digest-chunk-size "invalid positive-fixnum" x)
        (message-digest-chunk-size) ) ) ) ) )

;;

(: message-digest-chunk-port-read-maker (#!optional (or boolean procedure) -> procedure))
;
(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) ) ) ) ) )

;;

(: message-digest-chunk-fileno-read-maker (#!optional (or boolean procedure) -> procedure))
;
(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) ) ) ) ) )

;;

(: message-digest-chunk-converter (#!optional (or boolean procedure) -> (or boolean procedure)))
;
(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) ) ) ) ) )

) ;module message-digest-chunk