;;;; message-digest-port.scm
;;;; Kon Lovett, May '10
;;;; Kon Lovett, Aug '17

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

(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 chicken)
(use
  (only data-structures ->string)
  (only ports make-output-port with-input-from-port)
  (only srfi-13 string-suffix-length-ci)
  (only type-checks define-check+error-type check-output-port)
  (only type-errors error-argument-type make-error-type-message signal-type-error)
  message-digest-primitive
  message-digest-type
  message-digest-bv
  typed-define)

(declare
  (bound-to-procedure
    ##sys#slot ##sys#setslot))

;;; Support

;;fx-utils

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

;;

(include "message-digest-types")

;;

(define PORT-TAG 'digest)

(define PRIMITIVE-NAME-SUFFIXES '("p" "-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 (%port-name-set! p s)
  (##sys#setslot p 3 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 (
    (pt (%port-type (check-open-port loc (check-output-port loc obj argnam) argnam))) )
    (unless (eq? PORT-TAG pt)
      (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 (mdp message-digest-primitive)) --> string
  (let* (
    (nam
      (->string (or (message-digest-primitive-name mdp) 'md)))
    ;strip trailing (why ?)
    (remlen
      ;longest suffix length or negative
      (foldl
        (lambda (remlen suf)
          (fxmax remlen (string-suffix-length-ci nam suf)) )
        -1
        PRIMITIVE-NAME-SUFFIXES))
    (nam
      (if (fxpositive? remlen)
        (substring nam 0 (fx- (string-length nam) remlen))
        nam)) )
    (string-append "(" nam ")") ) )

;;; Message Digest Output Port API

(define: (open-output-digest (mdp message-digest-primitive)) -> digest-output-port
  (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)) )
    (##sys#set-port-data! port md)
    (%port-type-set! port PORT-TAG)
    (%port-name-set! port (make-digest-port-name mdp))
    port ) )

(: digest-output-port? (* -> boolean : digest-output-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 digest-output-port)) --> string
  (%port-name
    (check-digest-output-port 'digest-output-port-name port)) )

(define: (*close-output-digest (loc symbol) (port digest-output-port) (restyp message-digest-result-form)) -> message-digest-result-type
  (let (
    (res
      (finalize-message-digest
        (##sys#port-data
          (check-open-digest-output-port loc port 'digest-port))
        restyp)) )
    (close-output-port port)
    res ) )

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

;;;

(define: (call-with-output-digest (mdp message-digest-primitive) (proc procedure) . (opts (list message-digest-result-type))) -> message-digest-result-type
  (let (
    (restyp (optional opts (message-digest-result-form)))
    (port (open-output-digest mdp)) )
    (proc port)
    (*close-output-digest 'call-with-output-digest port restyp) ) )

(define: (with-output-to-digest (mdp message-digest-primitive) (thunk procedure) . (opts (list message-digest-result-type))) -> message-digest-result-type
  (let (
    (restyp (optional opts (message-digest-result-form))) )
    (call-with-output-digest mdp (cut with-input-from-port <> thunk) restyp) ) )

) ;module message-digest