filter.ss
#lang scheme/base

;; filter abstracts pre-procesing of port data.
;; examples are gzipped files.  Instead of reading raw, gzipped file, one can wrap
;; the file with a filter so one can read the file as if it has never been gzipped.
;;
;; there are 2 types of filters:
;; input-filter: it takes an input-port and a filter (which is a function that takes
;; both input-port & output-port) and produces an input-port
;; output-filter: takes an output-port and a filter to produce an output-port
;;
;; if one wants to chain multiple filters together, remember for input-filter, the
;; inner filter gets to process the data first, and for output-filter it is reversed
;; (so the outer filter gets to process the data first).
;;
;; once a while - you might reuse code that already provide custom pipes (and handles
;; the filtering at the custom pipe level) - in those case, you want to pass in copy-port
;; for the filter, and write an custom make-pipe-helper function, which takes in a port and
;; returns an input-port and an output-port.  The best example is the crypto-file...
(require (planet bzlib/base) "port.ss" scheme/port)

(define (make-pipe-helper port)
  (make-pipe (expt 2 15) (object-name port) (object-name port)))

(define (make-input-filter-port/1 input-port filter make-pipe) 
  (define (filter-helper)
    (if (not filter) copy-port filter))
  (define (pipe-helper)
    (if (not make-pipe) make-pipe-helper make-pipe))
  (let-values (((in out)
                ((pipe-helper) input-port)))
    (let* ((thd (thread (lambda () 
                          (call-with-input-port input-port
                                                (lambda (in)
                                                  ((filter-helper) in out)
                                                  (close-output-port out)))))))
      (make-input-port (object-name in)
                       (make-default-read in)
                       (make-default-peek in)
                       (lambda () 
                         (kill-thread thd)
                         (close-output-port out)
                         (close-input-port input-port)
                         (close-input-port in))))))

(define (make-output-filter-port/1 output-port filter make-pipe)
  (define (filter-helper)
    (if (not filter) copy-port filter))
  (define (pipe-helper)
    (if (not make-pipe) make-pipe-helper make-pipe))
  (let-values (((in out)
                ((pipe-helper) output-port)))
    (let* ((thd (thread (lambda () 
                          (call-with-output-port output-port
                                                 (lambda (out)
                                                   ((filter-helper) in out)
                                                   (close-input-port in))))))
           (thd-dead? (thread-dead-evt thd)))
      (make-output-port (object-name in)
                        always-evt
                        (lambda (bytes-out start end block? break?)
                          (if (= start end)
                              (flush-output out)
                              (write-bytes bytes-out out start end)))
                        (lambda () 
                          (begin0 (close-output-port out)
                                  (sync thd-dead?)))))))

(define (make-input-filter-port in filter make-pipe . rest) 
  ;; the outer filter gets to handle first... ;; so what we want to do is to *reverse the whole thing!!!
  (define (helper in filter make-pipe rest)
    (cond ((null? rest) ;; we are done!!!
           (make-input-filter-port/1 in filter make-pipe))
          ((null? (cdr rest)) 
           (error 'make-input-filter-port "uneven filter/pipe pairs: ~a" rest))
          (else
           (make-input-filter-port/1 (helper in (car rest) (cadr rest) (cddr rest))
                                      filter make-pipe))))
  (helper in filter make-pipe rest))

(define (make-output-filter-port out filter make-pipe . rest)
  ;; the outer filter gets to handle first... ;; so what we want to do is to *reverse the whole thing!!!
  (define (helper out filter make-pipe rest)
    (cond ((null? rest) ;; we are done!!!
           (make-output-filter-port/1 out filter make-pipe))
          ((null? (cdr rest)) 
           (error 'make-output-filter-port "uneven filter/pipe pairs: ~a" rest))
          (else
           (make-output-filter-port/1 (helper out (car rest) (cadr rest) (cddr rest))
                                      filter make-pipe))))
  (helper out filter make-pipe rest))

;; how
(define make-pipe/c 
  (-> port? (values input-port? output-port?)))

(define port-filter/c
  (-> input-port? output-port? any))

(provide/contract 
 (make-input-filter-port (->* (input-port? (or/c #f port-filter/c) (or/c #f make-pipe/c))
                              ()
                              #:rest (listof (or/c #f procedure?))
                              input-port?))
 (make-output-filter-port (->* (output-port? (or/c #f port-filter/c) (or/c #f make-pipe/c))
                               ()
                               #:rest (listof (or/c #f procedure?))
                               output-port?))
 )

(provide make-pipe/c port-filter/c)