(define-module(www server-utils form-2-form)#:export(parse-form)#:use-module(ice-9 curried-definitions)#:use-module((www mime-headers)#:select(p-ref parse-parameters parse-type typed?))#:use-module((www crlf)#:select(read-characters))#:use-module((srfi srfi-2)#:select(and-let*))#:use-module((srfi srfi-13)#:select(substring/shared string-prefix? string-contains))#:use-module((ice-9 regex)#:select(match:substring)))
(define +name-rx+(make-regexp "name=\"([^\"]*)\""))
(define +filename-rx+(make-regexp "filename=\"*([^\"\r]*)\"*"))
(define +type-rx+(make-regexp "Content-Type: ([^\r]*)\r"(logior regexp/icase)))
(define((m1-extract string)rx)(and-let*((m(regexp-exec rx string)))(match:substring m 1)))
(define(boundary<- type)(string-append "--"(p-ref type  'boundary)))
(define(parse-form type raw-data)(and(string? type)(set! type(if(memq(string-ref type 0) '(#\; #\space))(cons  '#f(parse-parameters type))(parse-type type))))(or(string? raw-data)(set! raw-data(read-characters raw-data)))(let((v '()))(define(v! name value)(set! v(acons name value v)))(define(u! name filename type bov eov raw-headers)(or(and(or(not filename)(string-null? filename))(= bov eov))(v! name(list filename type raw-headers(let((raw raw-data))(lambda(abr)(if(and raw abr)(abr raw bov eov)(set! raw #f))))))))(let level((bor 0)(eor(string-length raw-data))(boundary(boundary<- type))(parent-name #f))(define(find-bound from)(string-contains raw-data boundary from))(let get-pair((bop(find-bound bor)))(set! bop(+ bop(string-length boundary)))(and-let*(((<=(+ 2 bop)eor))((string-prefix? "\r\n" raw-data 0 2 bop))(boh(+ 2 bop))(bov(+ 4(string-contains raw-data "\r\n\r\n" boh)))(headers(substring/shared raw-data boh(- bov 2)))(hx(m1-extract headers))(name(or parent-name(hx +name-rx+)))(eop(find-bound bov))(eov(- eop 2)))(or(and-let*((stype(hx +type-rx+))(type(parse-type stype)))(if(and(not parent-name)(typed? type  'multipart  'mixed))(level bov eov(boundary<- type)name)(u! name(hx +filename-rx+)stype bov eov headers)))(= bov eov)(v! name(substring/shared raw-data bov eov)))(get-pair eop))))(reverse! v)))
