#lang scheme/base
(require "depend.ss"
"base.ss"
"type.ss"
"content-type.ss"
"content-disposition.ss"
"content-transfer-encoding.ss"
"mime.ss"
)
(define-struct (content mime) (body))
(mime-body-set! content? content-body)
(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
(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))))
(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"))
(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)
(define (content-body->input c)
(define (helper in)
(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))))
(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)))
(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)
(mime->input-helper m content-headers->input content-body->input))
(mime-writer-set! content? content->input)
(define (build-content #:id (id #f)
#:description (description #f)
#:type (type #f)
#:charset (charset #f)
#:disposition (disposition "inline")
#:headers (headers '())
#:path (path #f) #:filename (filename #f) (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
)