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

;;Issues
;;
;; - 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-read-maker ;DEPRECATED
  message-digest-chunk-converter)

(import scheme chicken foreign)
(use
  (only posix file-size)
  (only srfi-4
    u8vector->blob/shared subu8vector
    read-u8vector! make-u8vector)
  miscmacros
  typed-define)

;;; Support

;;fx-utils

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

;;

(include "message-digest-types")

;;; Update Phase Helpers

(define: (default-chunk-port-read-maker (port input-port) . (opts (list fixnum))) -> procedure
  (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:-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 fixnum message-digest-raw-chunk-size)
  (beg fixnum message-digest-raw-chunk-start) )

(define: (default-chunk-fileno-read-maker (fd fixnum) . (opts (list fixnum))) -> procedure
  (let (
    (siz (optional opts (file-size fd))) )
    (if (zero? siz)
      (lambda ()
        #f )
      (let-values (
        ((buffer cleanup)
          (mapped-buffer 'default-chunk-fileno-read-maker fd siz)) )
        (let (
          (chunk (make-message-digest-raw-chunk buffer siz 0)) )
          (lambda ()
            (if buffer
              (begin0
                chunk
                (set! buffer #f))
              (begin
                (cleanup)
                #f ) ) ) ) ) ) ) )

(cond-expand

  ((and windows (not cygwin))

    ;tested w/ macosx (replaced mmap version)

    (use (only lolevel 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 );") )

    ;(define: (mapped-buffer (loc symbol) (fd fixnum) (siz fixnum)) -> (pointer procedure)
    (: mapped-buffer (symbol fixnum fixnum -> pointer procedure))
    (define (mapped-buffer loc fd siz)
      (let* (
        (ptr (allocate siz))
        (finalize (cut free ptr)) )
        (unless (read-into-buffer fd ptr siz)
          (finalize)
          (error loc "cannot read file") )
        (values ptr finalize) ) ) )

  (else ;assume unix

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

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

;;

(define-constant DEFAULT-CHUNK-SIZE 1024)

;;; Message Digest "chunk"

;;

(: message-digest-chunk-size (#!optional fixnum -> fixnum))
;
(define-parameter message-digest-chunk-size 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-parameter message-digest-chunk-port-read-maker 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-read-maker message-digest-chunk-port-read-maker)

;;

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