;;;; message-digest-port.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18
;;;; Kon Lovett, Aug '17
;;;; Kon Lovett, May '10

;; Issues
;;
;; - Use of sys namespace routines.

(module message-digest-port

(;export
  digest-output-port? check-digest-output-port error-digest-output-port
  open-output-digest
  get-output-digest
  call-with-output-digest
  with-output-to-digest
  ;DEPRECATED
  digest-output-port-name)

(import scheme
  (chicken base)
  (chicken type)
  (only (chicken blob) blob?)
  (only (chicken string) ->string)
  (only (chicken port) port-name set-port-name! make-output-port with-output-to-port)
  (only (srfi 13) string-suffix-length-ci)
  (only type-checks-basic define-check+error-type)
  (only (check-errors sys) check-output-port check-procedure)
  (only type-errors-basic error-argument-type make-error-type-message signal-type-error)
  message-digest-primitive
  message-digest-type
  message-digest-item
  message-digest-byte-vector)

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

(: make-digest-port-name (message-digest-primitive -> string))
(: open-output-digest (message-digest-kind -> digest-output-port message-digest))
(: digest-output-port? (* -> boolean : digest-output-port))
(: *close-output-digest (symbol digest-output-port message-digest-result-form -> message-digest-result-type))
(: get-output-digest (digest-output-port message-digest #!rest -> message-digest-result-type))
(: call-with-output-digest (message-digest-kind procedure #!rest -> message-digest-result-type))
(: with-output-to-digest (message-digest-kind procedure #!rest -> message-digest-result-type))

(: digest-output-port-name (deprecated port-name))

;;

(define PRIMITIVE-NAME-SUFFIXES '("p" "-primitive"))

;;

(define (check-open-port loc obj #!optional argnam)
  (when (port-closed? obj)
    (error-argument-type loc obj "open port" argnam) )
  obj )

(define (check-open-digest-output-port loc obj)
  ;FIXME cannot distinguish "custom" ports
  (check-open-port loc (check-output-port loc obj)) )

;Synthesize a port-name from a primitive-name
;
(define make-digest-port-name
  ;need byte-oriented semantics
  (let ((substring substring))
    (lambda (mdp)
      (let* ((nam
              (->string (or (message-digest-primitive-name mdp) 'md)))
             ;strip trailing (why ?)
             (remlen
               ;longest suffix length or negative
               (foldl
                 (lambda (remlen suf)
                   (max remlen (string-suffix-length-ci nam suf)) )
                 -1
                 PRIMITIVE-NAME-SUFFIXES))
             (nam
               (if (positive? remlen)
                   (substring nam 0 (- (string-length nam) remlen))
                   nam)) )
        (string-append "(" nam ")") ) ) ) )

;;; Message Digest Output Port API

(define (open-output-digest mdk)
  (let* ((md (initialized-message-digest mdk))
         (writer (lambda (obj)
                   (cond ((string? obj)
                           (message-digest-update-string md obj))
                         ((blob? obj)
                           (message-digest-update-blob md obj))
                         ;FIXME ...
                         (else
                           (message-digest-object md obj)))) )
         ;use default close behavior
         (port (make-output-port writer void)) )
    (set-port-name! port (make-digest-port-name (message-digest-algorithm md)))
    (values port md) ) )

;
(define (digest-output-port? obj)
  ;FIXME cannot distinguish "custom" ports
  (output-port? obj) )

(define-check+error-type digest-output-port)

(define (digest-output-port-name port)
  (port-name (check-digest-output-port 'digest-output-port-name port)) )

(define (get-output-digest port md . opts)
  (check-open-digest-output-port 'get-output-digest port)
  (let ((restyp (optional opts (message-digest-result-form))))
    ;FIXME must be restyp
    (let ((res (finalize-message-digest md restyp)))
      (close-output-port port)
      res ) ) )

;;

(define (call-with-output-digest mdk proc . opts)
  (check-procedure 'call-with-output-digest proc)
  (let ((restyp (optional opts (message-digest-result-form))))
    ;FIXME must be restyp
    (let-values (((port md) (open-output-digest mdk)))
      (dynamic-wind
        void
        (lambda () (proc port) (finalize-message-digest md restyp))
        (lambda () (close-output-port port))) ) ) )

(define (with-output-to-digest mdk thunk . opts)
  (let ((restyp (optional opts (message-digest-result-form))))
    ;FIXME must be restyp
    (call-with-output-digest mdk (cut with-output-to-port <> thunk) restyp) ) )

) ;module message-digest