#lang scheme/base
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MIME.plt
;;
;; an extensible MIME framework.
;;
;; Bonzai Lab, LLC.  All rights reserved.
;;
;; Licensed under LGPL.
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; multipart.ss - represent the basic multipart/mixed structure...
;; yc 2/18/2010 - first version.
(require "depend.ss"
         "base.ss"
         "content-type.ss"
         "content-disposition.ss"
         "content-length.ss"
         "mime.ss"
         )
(define-struct (multipart mime) (parts preamble epilogue)) 

(mime-body-set! multipart? multipart-parts)

;; if we read the line and it is *NOT* a boundary...
;; then we should write the line in...
;; if we read another line and it is a boundary, then we are done.
;; the issue here is when do we write down line-term.
;; it seems that the line-term should just be stripped out???
;; another thing is that we should keep state....
;; so this one closes the port itself...
(define-struct mime-boundary-filter (boundary (start? #:mutable)
                                              (next? #:mutable)
                                              (end? #:mutable))
  #:property prop:procedure 
  (lambda ($s in out) 
    (let loop ((v (read-bytes-line in (line-term))))
      (cond ((or (eof-object? v)
                 (bytes=? v (bytes-append #"--"
                                          (mime-boundary-filter-boundary $s)
                                          #"--")))
             (set-mime-boundary-filter-end?! $s #t)
             (close-output-port out))
            ((bytes=? v (bytes-append #"--" 
                                      (mime-boundary-filter-boundary $s)))
             (set-mime-boundary-filter-next?! $s #t)
             (close-output-port out))
            (else
             (if (mime-boundary-filter-start? $s) 
                 (write-bytes (line-term/bytes) out)
                 (set-mime-boundary-filter-start?! $s #t))
             (write-bytes v out)
             (loop (read-bytes-line in (line-term))))))))

;; multipart is the hard one - because we need to read each of the parts individually
;; and we need to
(define (read-multipart-with-headers in headers)
  (define (helper type heades boundary in)
    (define (read-preamble in)
      (let ((filter (make-mime-boundary-filter (string->bytes/utf-8 boundary)
                                               #f #f #f)))
        (let ((preamble (port->bytes 
                         (make-input-filter-port #:close? #f 
                                                 in filter #f))))
          (cond ((mime-boundary-filter-next? filter) ;; we have more...
                 (read-parts in preamble '()))
                ((mime-boundary-filter-end? filter) ;; time for the
                 (read-epilogue in preamble '()))
                (else ;; this is an impossible condition unless erroring...
                 (error 'read-preamble "unknown error occured"))))))
    (define (read-parts in preamble acc)
      (let ((filter (make-mime-boundary-filter (string->bytes/utf-8 boundary) 
                                               #f #f #f)))
        (let ((part (read-mime
                     (make-input-filter-port #:close? #f
                                             in filter #f))))
          (cond ((mime-boundary-filter-next? filter)
                 (read-parts in preamble (cons part acc)))
                ((mime-boundary-filter-end? filter)
                 (read-epilogue in preamble (cons part acc)))
                (else (error 'read-parts "unknown error occured"))))))
    (define (read-epilogue in preamble parts)
      (make-multipart (kvs/list->kvlist headers) (reverse parts) preamble 
                      (port->bytes in)))
    (call-with-input-port in read-preamble))
    (helper (mime-type headers) 
            headers 
            (mime-boundary headers)
            in))

(mime-reader-set! "multipart" read-multipart-with-headers)

(define (multipart-preamble->input m) 
  (if (equal? (multipart-preamble m) #"")
      (multipart-preamble m)
      (bytes-append (multipart-preamble m) (line-term/bytes))))

(define (multipart-part-boundary m) 
  (format "--~a~a" (mime-boundary m) (line-term/bytes)))

(define (multipart-end-boundary m) 
  (format "--~a--~a" (mime-boundary m) (line-term/bytes)))

;; multipart->input...
(define (multipart-body->input m)
  (apply open-append-port 
         #t 
         (multipart-preamble->input m)
         (append (flatten (map (lambda (e) 
                                 (list (multipart-part-boundary m)
                                       (mime->input e)
                                       (line-term/bytes)))
                               (multipart-parts m)))
                 (list (multipart-end-boundary m)
                       (multipart-epilogue m)))))

(define (multipart->input m)
  (mime->input-helper m headers->string multipart-body->input)) 

(mime-writer-set! multipart? multipart->input)

;; build-multipart
(define (build-multipart #:type (type "multipart/mixed") 
                         #:boundary (boundary (uuid->string (make-uuid)))
                         #:preamble (preamble #"")
                         #:epilogue (epilogue #"")
                         . parts)
  (make-multipart `(("Content-Type" . ,(build-content-type type
                                                          `(("boundary" . ,boundary)))))
                  parts
                  preamble
                  epilogue))

(provide multipart 
         build-multipart 
         read-multipart-with-headers
         )

(provide/contract 
 (struct:multipart struct-type?)
 (multipart? isa/c) 
 (make-multipart (-> kvs/list? 
                     (listof (or/c mime?
                                   string? 
                                   bytes?)) 
                     (or/c string? bytes? false/c)
                     (or/c string? bytes? false/c)
                     multipart?))
 (multipart-parts (-> multipart? (listof (or/c mime? string? bytes?))))
 (multipart-preamble (-> multipart? (or/c false/c string? bytes?)))
 (multipart-epilogue (-> multipart? (or/c false/c string? bytes?)))
 )