#lang scheme/base
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MIME.plt
;;
;; an extensible MIME framework.
;;
;; Bonzai Lab, LLC.  All rights reserved.
;;
;; Licensed under LGPL.
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; content.ss - abstracts the "content" structure.
;; yc 2/9/2010 - add the ability to save to the an user-specific mime file!!.
(require "depend.ss"
         "base.ss"
         "type.ss"
         "content-type.ss"
         "content-disposition.ss"
         "content-transfer-encoding.ss"
         "mime.ss"
         )

;; content holds the data in memory
(define-struct (content mime) (body)) 

(mime-body-set! content? content-body)

;; what we need to do is to setup a set of encoding chains...
;; and then have the encoding & have them chain together...

;; 1 - apply transfer-encoding (chunked)
;; 2 - apply content-encoding (supposely this can be set to be *multiple* levels... hmm)...
;; 3 - apply content-transfer-encoding...
;; 4 - text vs bytes (charset conversion)...
;; so we want this to be *extensible*...
;; basically - it should take in a particular

;; so there would be a chain... the chain would then be *applied* based on a set of the transformation...
;; hmm... let's think through this on how to do it...
;; each function will process the content-body & then *return*

;; this is only something that is done via the MIME interface...
;; now this is clear...
(define (read-content-body encoding charset in)
  ((if (not charset) port->bytes port->string)
   (if (not charset)
       (make-input-filter-port in 
                               (case encoding 
                                 ((base64) 
                                  base64-decode-stream)
                                 ((quoted-printable) qp-decode-stream)
                                 (else copy-port)) 
                               #f)
       (make-input-filter-port in 
                               ;; #:close? #f
                               (lambda (in out) 
                                 (convert-stream charset
                                                 in 
                                                 "utf-8"
                                                 out))
                               #f 
                               (case encoding 
                                 ((base64) 
                                  base64-decode-stream)
                                 ((quoted-printable) qp-decode-stream)
                                 (else copy-port)) 
                               #f))))

;; when we are reading in entity, we are making a content object... for now...
;; we might make file in the future...
(define (read-content-with-headers in headers)
  (define (helper kvs)
    (kvs/list-del! (kvs/list-set! (kvs/list-del! kvs "Content-Transfer-Encoding")
                                  "Content-Type"
                                  (if (string-ci=? "text" (mime-basetype kvs))
                                      (kvs/list-set! (mime-content-type kvs)
                                                     "charset"
                                                     "utf-8")
                                      (mime-content-type kvs)))
                   "Content-Length"))
  ;; note that the order matters as kvs are mutable...
  (let ((encoding (mime-content-transfer-encoding headers))
        (charset (mime-charset headers)))
    (make-content (helper (kvs/list->kvlist headers)) 
                  (read-by-content-type (read-content-body encoding charset in) 
                                        headers))))

(mime-reader-set! "text" read-content-with-headers)
(mime-reader-set! "image" read-content-with-headers)
(mime-reader-set! "audio" read-content-with-headers)
(mime-reader-set! "video" read-content-with-headers)
(mime-reader-set! "application" read-content-with-headers)

;; let's start on entity->input.
;; the best way to handle the transfer-encoding is to have it parameterizable!!!
;; otherwise it's sure quite hard to make changes!!
(define (content-body->input c) 
  (define (helper in)
    ;; the type of the encoding should completely depend on the actual content-type that is being
    ;; encoded... hmm...
    (if (mime-include-content-transfer-encoding?)
        (let ((encoding (content-default-transfer-encoding c)))
          (case encoding
            ((7bit 8bit)
             (if (string-ci=? (mime-basetype c) "text")
                 (port->abytes (make-input-filter-port in line-term-filter #f))
                 in))
            ((binary) in)
            (else
             (port->abytes (make-input-filter-port 
                            in
                            (lambda (in out)
                              ((case encoding
                                 ((base64) base64-encode-stream)
                                 ((quoted-printable)
                                  qp-encode-stream))
                               in
                               out
                               (line-term/bytes)))
                            #f)))))
        in))
  (helper (content-type->input (content-body c))))

;; content-transfer-encoding rules only apply to content objects...
;; so this is where things *are* interesting*...
;; what are the rules for encoding?

;; 1 - all images, audio, video, and application should be base64 encoded...
;;     unless we want to allow for binary download (which is the case in HTTP).
;; (transfer-encoding) should then be able to go with a "default", so the intelligence
;; of the object can then take over...
;; 2 - the tough part of the encoding really goes into text...
;;     if there are a lot of cjk characters we would want to encode with base64
;;     if the characters are mostly ascii then use quoted-printable is better...
;;    
;; this is only doable if the content-body is string, and if the content-type
;; is text/*

;; so what's the heuristic?
;; if more than 70% of the characters are ascii - use quoted-printable...
;;
;; so - http does not make use of the content-transfer-encoding mechanism...
;; gotta think about how this would *fit* in...
;; what if I set the current encoding to be #f???

(define (content-default-transfer-encoding c)
  (case/string-ci=? (mime-basetype c) 
    (("image" "audio" "video" "application") 'base64)
    (("multipart" "message") 'binary)
    (("text")
     (if (string? (content-body c)) 
         (let-values (((ascii latin-1 unicode)
                       (string-char-ratios (content-body c))))
           (cond ((> ascii 0.65) 'quoted-printable)
                 (else 'base64)))
         'base64))
    (else 'base64)))
;; (trace content-default-transfer-encoding)

(define (content-headers->input m)
  (headers->string (if (mime-include-content-transfer-encoding?)
                       (kvs-set! m "Content-Transfer-Encoding" 
                                 (content-default-transfer-encoding m))
                       (kvs-del! m "Content-Transfer-Encoding"))))

(define (content->input m)
  ;; we should also insert a new header depending on the table...
  (mime->input-helper m content-headers->input content-body->input))

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


;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; build-content
;; this is the main constructor if we want to build something from "scratch"
;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (build-content #:id (id #f)
                       #:description (description #f)
                       #:type (type #f)
                       #:charset (charset #f) 
                       #:disposition (disposition "inline") 
                       #:headers (headers '())
                       #:path (path #f) ;; using this we will automatically populate
                       ;; other parts of the information regarding the file name...
                       #:filename (filename #f) ;; using this to *overwrite* filename
                       ;; parameter if we are trying to force a download...
                       (source ""))
  (define (id-helper headers)
    (if (not id)
        headers
        (kvs/list-set! headers "Content-ID" id)))
  (define (descr-helper headers)
    (if (not description)
        headers
        (kvs/list-set! headers "Content-Description" description)))
  (define (type-helper headers)
    (if (not type)
        (if (mime-content-type headers)
            headers
            (kvs/list-set! headers "Content-Type" content-type/default))
        (kvs/list-set! headers "Content-Type" 
                       (build-content-type type 
                                           (filter cdr
                                                   `(("charset" . ,charset)))))))
  (define (disposition-helper headers)
    (if (not disposition)
        (if (kvs/list-ref headers "Content-Disposition")
            headers
            (kvs/list-set! headers "Content-Disposition" 
                           (build-content-disposition disposition 
                                                      (filter cdr 
                                                              `(("filename" . ,filename))))))
            (kvs/list-set! headers "Content-Disposition" 
                           (build-content-disposition disposition 
                                                      (filter cdr 
                                                              `(("filename" . ,filename)))))))
  (define (length-helper headers)
    (kvs/list-del! headers "Content-Length"))
  (define (headers-helper headers)
    (length-helper (disposition-helper 
                    (type-helper (descr-helper (id-helper headers))))))
  (define (body-helper body)
    (if (and path (file-exists? path))
        path 
        body))
  (make-content (headers-helper headers)
                (body-helper source))) 

(provide/contract (read-content-with-headers (-> input-port? kvs/list? any))
                  (content->input (-> content? input-port?))
                  (struct:content struct-type?)
                  (content? isa/c)
                  (make-content (-> kvlist? any/c content?))
                  (content-body (-> content? any/c))
                  )
(provide content 
         build-content
         )