(define-module(www cgi)#:export(cgi:init cgi:getenv cgi:nv-pairs cgi:values cgi:value cgi:names cgi:form-data? cgi:uploads cgi:upload cgi:cookie-names cgi:cookies cgi:cookie)#:use-module((www server-utils parse-request)#:select(alist<-query))#:autoload(www mime-headers)(parse-type)#:autoload(www server-utils cookies)(simple-parse-cookies)#:autoload(www mime-multipart)(parse-multipart)#:autoload(www server-utils form-2-form)(parse-form)#:autoload(www crlf)(read-characters)#:use-module((srfi srfi-2)#:select(and-let*))#:use-module((srfi srfi-13)#:select(string-map! substring/shared string-index string-upcase string-tokenize))#:use-module((srfi srfi-14)#:select(char-set char-set-adjoin char-set-complement char-set:whitespace)))
(define(collate alist)(let((rv '()))(for-each(lambda(k v)(set! rv(or(and-let*((old(assoc-ref rv k)))(append! old(list v))rv)(acons k(list v)rv))))(map car alist)(map cdr alist))(reverse! rv)))
(define(split-on cs)(let((not-cs(char-set-complement cs)))(lambda(string)(string-tokenize string not-cs))))
(define ws/comma-split(split-on(char-set-adjoin char-set:whitespace #\,)))
(define getenv/symbol(let((ht(make-hash-table)))(define(squash-hyphen c)(if(char=? #\- c)#\_ c))(define(string<- symbol)(or(hashq-ref ht symbol)(let((str(string-upcase(symbol->string symbol))))(string-map! squash-hyphen str)(hashq-set! ht symbol str)str)))(lambda(symbol)(getenv(string<- symbol)))))
(define(env-look key)(define(server-sw-info)(and-let*((sw(getenv/symbol  'server-software)))(list sw(string-index sw #\/))))(define(server-pr-info)(and-let*((pr(getenv/symbol  'server-protocol)))(list pr(string-index pr #\/))))(define(extract make-args proc)(apply-to-args(make-args)proc))(case key((gateway-interface server-name server-software server-protocol auth-type request-method path-info path-translated script-name query-string remote-host remote-addr remote-user remote-ident content-type http-user-agent http-cookie)(getenv/symbol key))((server-hostname)(getenv/symbol  'server-name))((authentication-type)(getenv/symbol  'auth-type))((server-port)(and=>(getenv/symbol key)string->number))((content-length)(or(and=>(getenv/symbol key)string->number)0))((server-software-type)(extract server-sw-info(lambda(sw slash)(if slash(substring/shared sw 0 slash)sw))))((server-software-version)(extract server-sw-info(lambda(sw slash)(and slash(substring/shared sw(#{1+}# slash))))))((server-protocol-name)(extract server-pr-info(lambda(pr slash)(substring/shared pr 0 slash))))((server-protocol-version)(extract server-pr-info(lambda(pr slash)(substring/shared pr(#{1+}# slash)))))((http-accept http-accept-types)(or(and=>(getenv/symbol  'http-accept)ws/comma-split) '()))(else(error "unrecognized key:" key))))
(define(parse-form/move type len opt?)(define string-text/plain-please(opt?  'move-simple-text/plain))(define(reflow pair)(define move(car pair))(define(hget header)(p-ref pair header))(define(d key)(p-ref(hget  'Content-Disposition)key))(let*((filename(d  'filename))(type(hget  'Content-Type))(value(if(and string-text/plain-please(typed? type  'text  'plain)(not filename))(call-with-output-string move)(list(if(procedure? move)move(map reflow move))(hget  'Content-Length)type))))(list(d  'name)(or filename value)(and filename(cons filename value)))))(map reflow(parse-multipart type(current-input-port)len)))
(define(parse-form/squeeze-maybe type len opt?)(let((pre-squeezed?(not(opt?  'uploads-lazy)))(alist(parse-form type len)))(define(linear name rest)(define(upload filename type headers squeeze)(list filename(if pre-squeezed?(let((value(squeeze substring)))(set-object-property! value #:guile-www-cgi `((#:name unquote name)(#:filename unquote filename)(#:mime-type unquote type)(#:raw-mime-headers unquote headers)))value)rest)))(cons* name(if(string? rest)(list rest #f)(apply upload rest))))(map linear(map car alist)(map cdr alist))))
(define(make-ccc)(let((P '())(V '())(U '())(C '()))(define(P! x)(set! P x))(define(V! x)(set! V x))(define(U! x)(set! U x))(define(init! opts)(define(opt? symbol)(memq symbol opts))(define(alist<-qs s)(alist<-query s(opt?  'u8-qs)))(P! '())(V! '())(U! '())(and-let*((len(env-look  'content-length))((not(zero? len)))(type(parse-type(env-look  'content-type))))(cond((typed? type  'application  'x-www-form-urlencoded)(P!(alist<-qs(read-characters len))))((typed? type  'multipart  'form-data)(let((full((if(opt?  'move)parse-form/move parse-form/squeeze-maybe)type len opt?)))(define(extract-P name value upload)(cons name value))(define(extract-U name value upload)(and upload(cons name upload)))(define(map-ent proc)(map(lambda(ent)(apply proc ent))full))(P!(map-ent extract-P))(U!(delq #f(map-ent extract-U)))))))(and-let*((s(getenv/symbol  'query-string))((not(string-null? s))))(P!(append!(alist<-qs s)P)))(V!(collate P))(U!(collate U))(set! C(cond((env-look  'http-cookie)=>(lambda(raw)(collate(simple-parse-cookies raw(if(opt?  'cookies-split-on-semicolon)#\; #\,)))))(else '()))))(define(uploads name)(and-let*((pair(assoc name U)))(U!(delq pair U))(cdr pair)))(lambda (command . args)(define(one)(car args))(case command((#:init!)(init! args))((#:nv-pairs)P)((#:values)(assoc-ref V(one)))((#:value)(and=>(assoc-ref V(one))car))((#:names)(map car V))((#:form-data?)(not(null? P)))((#:uploads)(uploads(one)))((#:upload)(and=>(uploads(one))car))((#:cookie-names)(map car C))((#:cookies)(assoc-ref C(one)))((#:cookie)(and=>(assoc-ref C(one))car))(else(error "bad command:" command))))))
(define ONE #f)
(define (cgi:init . opts)(or ONE(set! ONE(make-ccc)))(apply ONE #:init! opts))
(define(cgi:getenv key)(or(env-look key)""))
(define(cgi:nv-pairs)(ONE #:nv-pairs))
(define(cgi:values name)(ONE #:values name))
(define(cgi:value name)(ONE #:value name))
(define(cgi:names)(ONE #:names))
(define(cgi:form-data?)(ONE #:form-data?))
(define(cgi:uploads name)(ONE #:uploads name))
(define(cgi:upload name)(ONE #:upload name))
(define(cgi:cookie-names)(ONE #:cookie-names))
(define(cgi:cookies name)(ONE #:cookies name))
(define(cgi:cookie name)(ONE #:cookie name))
