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

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

(declare
  (bound-to-procedure
    ##sys#slot ##sys#setslot
    ##sys#port-data ##sys#set-port-data!))

(module message-digest-port

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

(import scheme)
(import (chicken base))
(import (chicken type))
(import (only (chicken string) ->string))
(import (only (chicken port)
  make-output-port with-input-from-port))
(import (only (srfi 13) string-suffix-length-ci))
(import (only type-checks
  define-check+error-type
  check-output-port check-procedure))
(import (only type-errors
  error-argument-type make-error-type-message signal-type-error))
(import message-digest-primitive)
(import message-digest-type)
(import message-digest-byte-vector)

;; Support

;;

(include "message-digest.types")

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

;;

(define PORT-TAG 'digest)

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

;;% for primitive

(define (%port-type p)
  (##sys#slot p 7) )

(define (%port-type-set! p t)
  (##sys#setslot p 7 t) )

(define (%port-name p)
  (##sys#slot p 3) )

(define (%set-port-name! p s)
  (##sys#setslot p 3 s) )

(define (%port-data p)
  (##sys#port-data p) )

(define (%set-port-data! p s)
  (##sys#set-port-data! p s) )

;;

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

(define (check-open-digest-output-port loc obj #!optional argnam)
  (let (
    (port (%port-type (check-open-port loc (check-output-port loc obj argnam) argnam))) )
    (unless (eq? PORT-TAG port)
      (signal-type-error loc (make-error-type-message 'digest-output-port) obj argnam) ) )
  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 mdp)
  (check-message-digest-primitive 'open-output-digest mdp)
  (let* (
    (md
      (initialize-message-digest mdp))
    (writer
      (lambda (obj)
        ;for now only a string
        (if (string? obj)
          (message-digest-update-string md obj)
          (message-digest-update-blob md obj))))
      ;use default close behavior
      (port
        (make-output-port writer void)) )
    (%set-port-data! port md)
    (%port-type-set! port PORT-TAG)
    (%set-port-name! port (make-digest-port-name mdp))
    port ) )

;
(define (digest-output-port? obj)
  (and
    (output-port? obj)
    (eq? PORT-TAG (%port-type 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 (*close-output-digest loc port restyp)
  (check-open-digest-output-port loc port 'digest-port)
  (let (
    ;must be restyp
    (res '||) )
    (dynamic-wind
      (lambda () (set! res (finalize-message-digest (%port-data port) restyp)))
      (lambda () res)
      (lambda () (close-output-port port))) ) )

(define (get-output-digest port . opts)
  (let (
    (restyp (optional opts (message-digest-result-form))) )
    (*close-output-digest 'get-output-digest port restyp) ) )

;;

(define (call-with-output-digest mdp proc . opts)
  (check-procedure 'call-with-output-digest proc)
  (check-message-digest-primitive 'call-with-output-digest mdp)
  (let (
    (restyp (optional opts (message-digest-result-form))) )
    (let (
      (port (open-output-digest mdp)) )
      (dynamic-wind
        void
        (lambda () (proc port))
        (lambda () (*close-output-digest 'call-with-output-digest port restyp))) ) ) )

(define (with-output-to-digest mdp thunk . opts)
  (let (
    (restyp (optional opts (message-digest-result-form))) )
    (call-with-output-digest
      mdp #;(check-message-digest-primitive 'with-output-to-digest mdp)
      (cut with-input-from-port <> thunk) restyp) ) )

) ;module message-digest