#lang scheme/base
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MIME.plt
;;
;; an extensible MIME framework.
;;
;; Bonzai Lab, LLC.  All rights reserved.
;;
;; Licensed under LGPL.
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; mime.ss - the base functions surrounding a mime object...
;; yc 2/9/2010 - add the ability to save to the an user-specific mime file!!.

(require scheme/contract
         scheme/string
         "base.ss"
         "depend.ss"
         "content-type.ss"
         "content-disposition.ss"
         "content-transfer-encoding.ss"
         "content-length.ss"
         )

;; each of the spair are actually headers in mime!!!!...
;; http can also be modified to run off of the same thing as a regular entity!!!
;; (define-struct (mime headers) (body))

(define (mime-content-type m)
  (kvs/list-ref m "Content-Type" content-type/default))

(define (set-mime-content-type! m type (params '()))
  (kvs/list-set! m "Content-Type" (build-content-type type params)))

(define (mime-type m)
  (content-type/full (mime-content-type m))) 

(define (set-mime-type! m type)
  (set-mime-content-type! m type (kvs-inner (mime-content-type m))))

(define (mime-basetype m)
  (content-type-base (mime-content-type m)))

(define (mime-subtype m)
  (content-type-sub (mime-content-type m))) 

(define (mime-id m) 
  (kvs-ref m "content-id" #f)) 

(define (mime-description m) 
  (kvs/list-ref m "content-description" #f)) 

(define (mime-content-transfer-encoding m)
  (kvs/list-ref m "content-transfer-encoding" (content-transfer-encoding)))

(define (set-mime-content-transfer-encoding m (encoding (content-transfer-encoding)))
  (kvs/list-set! m "Content-Transfer-Encoding" encoding))

(define (mime-content-disposition m)
  (kvs/list-set! m "content-disposition"))

;; all of the above should be available in multiple different ways...
;; now - entity does have

(define (mime-charset m) 
  (define (helper content-type)
    (kvs/list-ref content-type "charset"))
  (helper (mime-content-type m)))

;; while these bindings are *cool*... they probably shouldn't be entertained
;; all that much for now, since the goal isn't to
(define (mime-boundary m) 
  (kvs/list-ref (mime-content-type m) "boundary")) 

;; we now need to have a way to extend the reading for mimes...
(define (read-mime in (headers #f))
  (if (not headers)
      (parameterize ((kvs-readertable (mime-header-reader-list)))
        (read-mime-with-headers in (read-headers in)))
      (read-mime-with-headers in headers)))
;; (trace read-mime)

(define (make-default-mime-with-headers in headers)
  headers)

(define (mime-header? kv) 
  (define (helper header)
    (or (string-ci=? "mime-version" header)
        (regexp-match #px"(?i:content-)" header)))
  (helper (car kv)))

(define (filter-mime-headers m)
  (filter mime-header? (kvs/list->kvlist m)))

(define (filter-non-mime-headers m)
  (filter (compose not mime-header?) (kvs/list->kvlist m)))

;; the key is how to read the mime based on the content-type...
;; so there really isn't much more beyond that!!!
;; cool!!!
(define (read-mime-with-headers in (headers '()))
  (define (read-mime-helper type base-type)
    (mime-reader-ref type 
                     (mime-reader-ref base-type
                                      make-default-mime-with-headers)))
  ((read-mime-helper (mime-type headers) (mime-basetype headers)) in headers))

;; on the other hand, we'll handle the conversion back in the same fashion as well!!!
;;
;; we now need to ensure we have the right definition for the mime body
;; 1 - bytes
;; 2 - string
;; 3 - a list of mime objects
;; 4 - a list of mime compatible objects...

;; mime->input
;; this is going to be quite similar to mime-readertable... we need a mime-writertable
(define (mime->input m) 
  ((mime-writer-ref m 
                    (lambda (m) 
                      (error 'mime->input 
                             "invalid type: ~a" m))) m))

(define (mime->bytes m)
  (port->bytes (mime->input m)))

(define (mime->input-helper m header->input body->input)
  (let ((body (body->input m))) 
    (open-append-port #t 
                      (header->input (cond ((mime-include-content-length?)
                                            (kvs/list-set! m "Content-Length" 
                                                           (input-port-length body)))
                                           (else m)))
                      body)))

(string-converter-set! date? date->rfc822)
(string-converter-set! email-address? email-address->string)
(string-converter-set! (listof? email-address?)
                       (lambda (lst)
                         (string-join (map email-address->string lst) ", ")))
(string-converter-set! mail-list? mail-list->string)

(provide/contract 
 (mime-type (-> kvs/list? string?))
 (mime-content-type (-> kvs/list? content-type?))
 (set-mime-type! (-> kvs/list? string? kvs/list?))
 (set-mime-content-type! (->* (kvs/list? string?)
                              (kvs/list?)
                              kvs/list?))
 (mime-content-disposition (-> kvs/list? (or/c false/c content-disposition?)))
 (mime-basetype (-> kvs/list? string?))
 (mime-subtype (-> kvs/list? string?))
 (read-mime (->* (input-port?)
                 ((or/c false/c kvs/list?)) 
                 any))
 (mime-boundary (-> kvs/list? (or/c false/c string?)))
 (mime-charset (-> kvs/list? (or/c false/c string?)))
 (mime-content-transfer-encoding (-> kvs/list? content-transfer-encoding?))
 (set-mime-content-transfer-encoding (->* (kvs/list?)
                                          (content-transfer-encoding?)
                                          kvs?))
 (filter-mime-headers (-> kvs/list? kvs/list?))
 (filter-non-mime-headers (-> kvs/list? kvs/list?))
 (mime->input (-> kvs/list? input-port?))
 (mime->input-helper (-> kvs/list? (-> kvs/list? any) (-> kvs/list? any) input-port?))
 (mime->bytes (-> kvs/list? bytes?))
 )