(define-module(www mime-headers)#:export(p-ref parse-parameters parse-type typed? top-typed? parse-headers)#:use-module((srfi srfi-11)#:select(let-values))#:use-module((srfi srfi-13)#:select(string-trim-right string-titlecase string-index substring/shared))#:use-module((srfi srfi-14)#:select(char-set-difference char-set:ascii char-set:iso-control char-set:upper-case string->char-set char-set->string))#:use-module((ice-9 regex)#:select(match:end match:substring))#:use-module((www crlf)#:select(read-headers hsym-proc)))
(define(p-ref form parameter)(assq-ref(cdr form)parameter))
(define(character-class-rx x)(make-regexp(string-append "["(if(string? x)x(char-set->string x))"]" "+")))
(define %TOKEN(character-class-rx(char-set-difference char-set:ascii char-set:iso-control(string->char-set " ()<>@,;:\\\"/[]?="))))
(define %SKIP-BEF(character-class-rx "; "))
(define %SKIP-MID(make-regexp " *= *"))
(define(downcase-if-necessary string)(if(string-index string char-set:upper-case)(string-downcase string)string))
(define(read-parameter start s)(define (sub beg . end)(apply substring/shared s beg end))(define(m! rx start)(regexp-exec rx s start))(define(quoted-string-value v-beg)(let((port(open-input-string s)))(seek port v-beg SEEK_SET)(let*((v(read port))(v-end(ftell port)))(values v v-end))))(define(token-value v-beg)(let((m(m! %TOKEN v-beg)))(values(match:substring m 0)(match:end m))))(let*((n-beg(match:end(m! %SKIP-BEF start)))(n-end(match:end(m! %TOKEN n-beg)))(v-beg(match:end(m! %SKIP-MID n-end))))(let-values(((v v-end)((if(char=? #\"(string-ref s v-beg))quoted-string-value token-value)v-beg)))(values(cons(string->symbol(downcase-if-necessary(sub n-beg n-end)))v)v-end))))
(define(parse-parameters s)(set! s(string-trim-right s))(let((len(string-length s)))(let loop((start 0)(acc '()))(if(= len start)(reverse! acc)(let-values(((p p-end)(read-parameter start s)))(loop p-end(cons p acc)))))))
(define(default-Content-Type)(copy-tree '((text . plain) (charset . "ISO-8859-1"))))
(define(token-from s pos)(regexp-exec %TOKEN s pos))
(define(sym m)(string->symbol(downcase-if-necessary(match:substring m 0))))
(define(parms s m)(parse-parameters(substring/shared s(match:end m))))
(define(parse-type s)(let*((m-top(token-from s 0))(m-sub(token-from s(#{1+}#(match:end m-top)))))(acons(sym m-top)(sym m-sub)(parms s m-sub))))
(define(typed? type top sub)(let((pair(car type)))(and(eq?(car pair)top)(eq?(cdr pair)sub))))
(define(top-typed? type top)(eq?(caar type)top))
(define parse-headers(let((norm(hsym-proc string-titlecase)))(lambda(port)(let((all(read-headers port norm)))(define(have header)(assq header all))(cond((have  'Content-Type)=>(lambda(pair)(set-cdr! pair(parse-type(cdr pair)))))(else(set! all(acons  'Content-Type(default-Content-Type)all))))(and=>(have  'Content-Disposition)(lambda(pair)(let*((s(cdr pair))(m-disp(token-from s 0)))(set-cdr! pair(cons(sym m-disp)(parms s m-disp))))))(and=>(have  'Content-Length)(lambda(pair)(set-cdr! pair(string->number(cdr pair)))))all))))
