Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 21:59:17 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Mime bug fixes for http server.

Browse source
This commit is contained in:
Alex Shinn 2013-12-21 18:19:40 +09:00
parent b0b2a5c5d2
commit 7fa49f0747
1 changed files with 46 additions and 20 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

66
lib/chibi/mime.scm
View file

@ -172,7 +172,9 @@
;;> } ;;> }
(define (mime-parse-content-type str) (define (mime-parse-content-type str)
(let ((res (map mime-split-name+value (string-split str #\;)))) (let ((res (map mime-split-name+value
(string-split str (lambda (ch)
(or (eqv? ch #\;) (eqv? ch #\,)))))))
(if (and (pair? res) (pair? (car res)) (equal? "" (cdar res))) (if (and (pair? res) (pair? (car res)) (equal? "" (cdar res)))
(cons (caar res) (cdr res)) (cons (caar res) (cdr res))
res))) res)))
@ -241,10 +243,13 @@
;;> \subsubsection{RFC2045 MIME Encoding} ;;> \subsubsection{RFC2045 MIME Encoding}
;;> \subsubsubsection{\scheme{(mime-message-fold src kons knil [start end headers])}} ;;> \subsubsubsection{\scheme{(mime-message-fold src kons knil [down up headers])}}
;;> Performs a fold operation on the given string or port \var{src} as a ;;> Performs a tree fold operation on the given string or port
;;> MIME body corresponding to the headers give in \var{headers}. \var{kons} ;;> \var{src} as a MIME body corresponding to the headers give in
;;> is called on the successive values: ;;> \var{headers}. If \var{headers} are false or not provided they
;;> are first read from \var{src}.
;;>
;;> \var{kons} is called on the successive values:
;;> ;;>
;;> \schemeblock{(kons parent-headers part-headers part-body accumulator)} ;;> \schemeblock{(kons parent-headers part-headers part-body accumulator)}
;;> ;;>
@ -252,21 +257,37 @@
;;> original headers for single-part MIME), \var{part-body} is the ;;> original headers for single-part MIME), \var{part-body} is the
;;> appropriately decoded and charset-converted body of the message, ;;> appropriately decoded and charset-converted body of the message,
;;> and the \var{accumulator} begins with \var{knil}. ;;> and the \var{accumulator} begins with \var{knil}.
;;>
;;> If a multipart body is found, then a tree fold is performed,
;;> calling \var{down} once to get a new accumulator to pass to
;;> \var{kons}, and \var{up} on the result when returning. Their
;;> signatures are:
;;>
;;> \schemeblock{(down headers seed)}
;;> \schemeblock{(up headers parent-seed seed)}
;;>
;;> The default \var{down} simply returns null, and the default
;;> \var{up} wraps the seed in the following sxml:
;;>
;;> \schemeblock{
;;> ((mime (@ headers ...)
;;> seed ...)
;;> parent-seed ...)
;;> }
(define (mime-message-fold src kons init-seed . o) (define (mime-message-fold src kons init-seed . o)
(let ((port (if (string? src) (open-input-string src) src))) (let ((port (if (string? src) (open-input-string src) src)))
(let ((kons-start (let ((kons-down
(if (pair? o) (car o) (lambda (headers seed) '()))) (or (and (pair? o) (car o)) (lambda (headers seed) '())))
(kons-end (kons-up
(if (and (pair? o) (pair? (cdr o))) (or (and (pair? o) (pair? (cdr o)) (car (cdr o)))
(car (cdr o))
(lambda (headers parent-seed seed) (lambda (headers parent-seed seed)
`((mime (@ ,@headers) `((mime (@ ,@headers)
,@(if (pair? seed) (reverse seed) seed)) ,@(if (pair? seed) (reverse seed) seed))
,@parent-seed)))) ,@parent-seed))))
(headers (headers
(if (and (pair? o) (pair? (cdr o)) (pair? (cdr (cdr o)))) (or (and (pair? o) (pair? (cdr o)) (pair? (cdr (cdr o)))
(car (cdr (cdr o))) (car (cdr (cdr o))))
(mime-headers->list port)))) (mime-headers->list port))))
(let tfold ((parent-headers '()) (let tfold ((parent-headers '())
(headers headers) (headers headers)
@ -284,23 +305,25 @@
(or (assq-ref headers 'content-transfer-encoding) (or (assq-ref headers 'content-transfer-encoding)
(assq-ref headers 'encoding "7-bit"))))) (assq-ref headers 'encoding "7-bit")))))
(cond (cond
((and (string-prefix? "multipart/" (symbol->string type)) ((and (symbol? type)
(assq-ref ctype 'boundary)) (string-prefix? "multipart/" (symbol->string type))
(assq-ref (cdr ctype) 'boundary))
=> (lambda (boundary2) => (lambda (boundary2)
(let ((boundary2 (string-append "--" boundary2))) (let ((boundary2 (string-append "--" boundary2)))
;; skip preamble ;; skip preamble
(mime-read-to-boundary port boundary2 (lambda (x) x) (lambda (x) x)) (mime-read-to-boundary port boundary2 (lambda (x) x) (lambda (x) x))
(let lp ((part-seed (kons-start headers seed))) (let lp ((part-seed (kons-down headers seed)))
(let ((part-headers (mime-headers->list port))) (let ((part-headers (mime-headers->list port)))
(tfold parent-headers part-headers (tfold headers part-headers
part-seed boundary2 part-seed boundary2
lp lp
(lambda (x) (lambda (x)
;; skip epilogue ;; skip epilogue
(if boundary (if boundary
(mime-read-to-boundary port boundary (mime-read-to-boundary
(lambda (x) x) (lambda (x) x))) port boundary
(next (kons-end headers seed x))))))))) (lambda (x) x) (lambda (x) x)))
(next (kons-up headers seed x)))))))))
(else (else
(mime-read-part (mime-read-part
port cte enc boundary port cte enc boundary
@ -319,7 +342,10 @@
mime-message-fold mime-message-fold
(if (pair? o) (car o) (current-input-port)) (if (pair? o) (car o) (current-input-port))
(lambda (parent-headers headers body seed) (lambda (parent-headers headers body seed)
`((mime (@ ,@headers) ,body) ,@seed)) ;; Discard empty bodies.
(if (and (equal? body "") (null? headers))
seed
`((mime (@ ,@headers) ,body) ,@seed)))
'() '()
(lambda (headers seed) '()) (lambda (headers seed) '())
(lambda (headers parent-seed seed) (lambda (headers parent-seed seed)