(define-module(www data mime-types)#:export(reset-mime-types! put-mime-types-from-file! put-mime-types! mime-types<-extension select-extensions)#:autoload(ice-9 rdelim)(read-line)#:autoload(srfi srfi-13)(string-tokenize string-index)#:autoload(srfi srfi-14)(char-set char-set-complement))
(define MT #f)
(define(proc-error proc)(lambda (key fmt . args)(scm-error key(procedure-name proc)fmt args #f)))
(define(hasher proc resolve)(define(verr kind x)((proc-error proc)(symbol-append  'invalid- kind)"Invalid ~A: ~S" kind x))(define(validate-extension x)(or(and(symbol? x))(verr  'extension x)))(define(validate-mime-type x)(or(and(symbol? x)(let*((s(symbol->string x))(pos(string-index s #\/)))(and pos(not(string-index s #\/(#{1+}# pos))))))(verr  'mime-type x)))(define(resolve<-resolve resolve)(define(b-list-w/o-c c b)(delq! c(if(symbol? b)(list b)b)))(define(conflict a b c)((proc-error proc) 'mime-type-conflict "Conflict for extension: ~A~%  old: ~A~%  new: ~A" a b c))(case resolve((error)conflict)((prefix)(lambda(a b c)(cons c(b-list-w/o-c c b))))((suffix)(lambda(a b c)(append!(b-list-w/o-c c b)(list c))))((stomp)(lambda(a b c)c))((quail)(lambda(a b c)b))(else(verr  'resolve resolve))))(set! resolve(resolve<-resolve resolve))(lambda(ext mime-type)(validate-extension ext)(cond(mime-type(if(pair? mime-type)(for-each validate-mime-type mime-type)(validate-mime-type mime-type))(hashq-set! MT ext(cond((hashq-ref MT ext)=>(lambda(prev)(if(equal? prev mime-type)prev(resolve ext prev mime-type))))(else mime-type))))(else(hashq-remove! MT ext)))))
(define(reset-mime-types! size)(set! MT(make-hash-table size)))
(define(put-mime-types-from-file! resolve filename)(let((hash!!(hasher put-mime-types-from-file! resolve))(cs(char-set-complement(char-set #\space #\tab)))(p(open-input-file filename)))(let loop((line(read-line p)))(or(eof-object? line)(begin(cond((string-null? line))((char=? #\#(string-ref line 0)))(else(let*((ls(delete ""(string-tokenize line cs)))(mime-type(string->symbol(car ls))))(for-each(lambda(ext)(hash!! ext mime-type))(map string->symbol(cdr ls))))))(loop(read-line p)))))(close-port p)))
(define (put-mime-types! resolve . rest)(let((hash!!(hasher put-mime-types! resolve)))(let loop((ls rest))(or(null? ls)(let((ext(car ls)))(set! ls(cdr ls))(and(null? ls)((proc-error put-mime-types!) 'missing-mime-type "Missing mime-type for extension: ~A" ext))(hash!! ext(car ls))(loop(cdr ls)))))))
(define(mime-types<-extension ext)(let((v(hashq-ref MT(if(string? ext)(string->symbol ext)ext))))(if(pair? v)(list-copy v)v)))
(define(select-extensions sel)(set! sel(case sel((#t)(lambda(v)#t))((single)symbol?)((multiple)pair?)))(let*((box(list #f))(tp box))(hash-for-each(lambda(k v)(and(sel v)(begin(set-cdr! tp(list k))(set! tp(cdr tp)))))MT)(cdr box)))
(reset-mime-types! 3)
(apply put-mime-types! '(stomp text text/plain html text/html))
