(define-module(www post)#:export(formatted-form-for-http:post-form)#:use-module((www url-coding)#:select(url-coding:encode))#:use-module((srfi srfi-11)#:select(let-values))#:use-module((srfi srfi-13)#:select(string-concatenate-reverse string-join))#:use-module(ice-9 optargs))
(define (fs s . args)(apply simple-format #f s args))
(define(string<-tree tree)(let((acc '()))(define(walk x)(cond((string? x)(set! acc(cons x acc)))((pair? x)(for-each walk x))))(walk tree)(string-concatenate-reverse acc)))
(define(formatted-form-for-http:post-form fields)(define(simple? field)(not(pair?(cdr field))))(define(urlenc x)(url-coding:encode(cond((string? x)x)((symbol? x)(symbol->string x))(else(object->string x))) '(#\& #\=)))(define*(c-type type #:optional boundary)(fs "Content-Type: ~A~A" type(if boundary(fs "; boundary=~S" boundary)"")))(or(and-map pair? fields)(error "bad fields:" fields))(if(and-map simple? fields)(values(list(c-type "application/x-www-form-urlencoded"))(string-join(map(lambda(pair)(string-append(urlenc(car pair))"="(urlenc(cdr pair))))fields)"&"))(let((boundary "gUiLeWwWhTtPpOsTfOrM"))(define*(c-disp disp name #:optional f?)(fs "Content-Disposition: ~A; ~Aname=\"~A\"" disp(if f? "file" "")name))(values(list(c-type "multipart/form-data" boundary))(let*((sub-b(string-append "SuB" boundary)))(define(do-simple pair)(values(list(c-disp "form-data"(car pair)))(cdr pair)))(define(source: spec)(list-ref spec 0))(define(name: spec)(list-ref spec 1))(define(mime-type: spec)(or(list-ref spec 2)"text/plain"))(define(xfer-enc: spec)(or(list-ref spec 3)"binary"))(define(validate-upload-spec spec)(define(string-or-symbol? obj)(or(string? obj)(symbol? obj)))(or(and(list? spec)(= 4(length spec))(and=>(source: spec)(lambda(source)(or(thunk? source)(string? source))))(and=>(name: spec)string-or-symbol?)(and=>(mime-type: spec)string-or-symbol?)(and=>(xfer-enc: spec)string-or-symbol?))(error "bad upload spec:" spec)))(define(emit-parts boundary ls proc)(let((b-line(string-append "--" boundary)))(define(term x)(list x "\r\n"))(define(part x)(let-values(((headers body)(proc x)))(map term(list b-line(map term headers)body)))) `( ,@(map part ls) ,(string-append b-line "--"))))(define(do-upload name-spec)(values(list(c-disp "form-data"(car name-spec))(c-type "multipart/mixed" sub-b))(emit-parts sub-b(cdr name-spec)(lambda(spec)(validate-upload-spec spec)(values(list(c-disp "attachment"(basename(name: spec))#t)(c-type(mime-type: spec))(fs "Content-Transfer-Encoding: ~A"(xfer-enc: spec)))(list(let((s(source: spec)))(if(thunk? s)(s)s))))))))(string<-tree(emit-parts boundary fields(lambda(field)((if(simple? field)do-simple do-upload)field)))))))))
