(define-module(www server-utils filesystem)#:export(access-forbidden?-proc cleanup-filename upath->filename-proc filename->content-type default-text-charset fully-specified)#:use-module((srfi srfi-2)#:select(and-let*))#:use-module((srfi srfi-13)#:select(string= (substring/shared . subs) string-prefix? string-suffix? string-tokenize string-join))#:use-module((srfi srfi-14)#:select(char-set-complement char-set))#:use-module(ice-9 optargs)#:autoload(www data mime-types)(mime-types<-extension))
(define(access-forbidden?-proc docroot forbid-rx)(let((rx(and forbid-rx(make-regexp forbid-rx))))(lambda(filename)(or(not(string-prefix? docroot filename))(and rx(regexp-exec rx filename))))))
(define +not-slash+(char-set-complement(char-set #\/)))
(define(cleanup-filename name)(define(not-dot-dot ls)(not(string= ".."(car ls))))(let*((abs?(string-prefix? "/" name))(comps(string-tokenize name +not-slash+))(end-slash?(string-suffix? "/" name))(dir?(or end-slash?(and(not(null? comps))(member(car(last-pair comps)) '("." "..")))))(head-dd(let loop((n 0))(cond((or(null? comps)(not-dot-dot comps))(set! comps(delete "." comps))n)(else(set! comps(cdr comps))(loop(#{1+}# n)))))))(let loop((rev(if abs? '()(make-list head-dd ".."))))(if(null? comps)(string-join(reverse!(if(and dir?(or end-slash?(not(pair? rev))(not-dot-dot rev)))(cons "" rev)rev))"/"(if abs?  'prefix  'infix))(let((one(car comps)))(set! comps(cdr comps))(loop(cond((not(string= ".." one))(cons one rev))((pair? rev)(cdr rev))(abs? rev)(else(cons one rev)))))))))
(define*(upath->filename-proc docroot #:optional(dir-indexes '()))(lambda(upath)(let((filename(cleanup-filename(in-vicinity docroot upath))))(and(file-exists? filename)(case(stat:type(stat filename))((regular)filename)((directory)(set! filename(in-vicinity filename ""))(let loop((ls dir-indexes))(cond((null? ls)filename)((eq? #f(car ls))#f)(else(let((full(string-append filename(car ls))))(or(and(file-exists? full)(eq?  'regular(stat:type(stat full)))full)(loop(cdr ls))))))))(else #f))))))
(define*(filename->content-type filename #:optional(default "application/octet-stream"))(or(and-let*((cut(string-rindex filename #\.))(mt(mime-types<-extension(subs filename(#{1+}# cut)))))(symbol->string(if(pair? mt)(car mt)mt)))default))
(define default-text-charset(let((f(make-fluid)))(fluid-set! f "ISO-8859-1")f))
(define(fully-specified lead mime-type)(cond((string-prefix? "text/" mime-type)(let((tcs(fluid-ref default-text-charset)))(case lead((type)(list lead mime-type  'charset tcs))(else(list lead(string-append mime-type ";charset=" tcs))))))(else(list lead mime-type))))
