;;; Copyright (C) 2005 FSF
;;; METAINFO: /y/people/emsley/autobuild/IRIX64-batman/share/guile/site/www/METAINFO
(define-module(www cgi)#:use-module(www url-coding)#:use-module(ice-9 regex)#:use-module(srfi srfi-13)#:use-module(ice-9 optargs)#:export(cgi:init cgi:getenv cgi:nv-pairs cgi:values cgi:value cgi:names cgi:form-data? cgi:uploads cgi:upload cgi:cookies cgi:cookie cgi:make-cookie))(define subs make-shared-substring)(define (fs s . args)(apply simple-format #f s args))(define(read-n-bytes num)(let((p(current-input-port))(s(make-string num)))(do((i 0(+ i 1))(ch(read-char p)(read-char p)))((or(>= i num)(eof-object? ch))s)(string-set! s i ch))))(define(separate-fields-discarding-char ch str)(let loop((fields(quote()))(str str))(let((pos(string-rindex str ch)))(if pos(loop(cons(subs str(+ 1 pos))fields)(subs str 0 pos))(cons str fields)))))(define(updated-alist alist name value)(or(and=>(assoc-ref alist name)(lambda(old)(append! old(list value))alist))(acons name(list value)alist)))(define(env-extraction-methods)(define(server-sw-info)(and=>(getenv "SERVER_SOFTWARE")(lambda(sw)(list sw(string-index sw #\/)))))(define(server-pr-info)(and=>(getenv "SERVER_PROTOCOL")(lambda(pr)(list pr(string-index pr #\/)))))(define(extract make-args proc)(apply-to-args(make-args)proc))(quasiquote(server-hostname "SERVER_NAME" gateway-interface "GATEWAY_INTERFACE" server-port(unquote(lambda()(and=>(getenv "SERVER_PORT")string->number)))request-method "REQUEST_METHOD" path-info "PATH_INFO" path-translated "PATH_TRANSLATED" script-name "SCRIPT_NAME" query-string "QUERY_STRING" remote-host "REMOTE_HOST" remote-addr "REMOTE_ADDR" authentication-type "AUTH_TYPE" remote-user "REMOTE_USER" remote-ident "REMOTE_IDENT" content-type "CONTENT_TYPE" content-length(unquote(lambda()(or(and=>(getenv "CONTENT_LENGTH")string->number)0)))http-user-agent "HTTP_USER_AGENT" http-cookie "HTTP_COOKIE" server-software-type(unquote(lambda()(extract server-sw-info(lambda(sw slash)(if slash(subs sw 0 slash)sw)))))server-software-version(unquote(lambda()(extract server-sw-info(lambda(sw slash)(and slash(subs sw(1+ slash)))))))server-protocol-name(unquote(lambda()(extract server-pr-info(lambda(pr slash)(subs pr 0 slash)))))server-protocol-version(unquote(lambda()(extract server-pr-info(lambda(pr slash)(subs pr(1+ slash))))))http-accept-types(unquote(lambda()(and=>(getenv "HTTP_ACCEPT")(lambda(types)(map(lambda(s)(if(char=? #\space(string-ref s 0))(subs s 1)s))(separate-fields-discarding-char #\, types)))))))))(define *env-extraction*(let((ht(make-hash-table 23)))(let loop((ls(env-extraction-methods)))(or(null? ls)(let((var(car ls)))(hashq-set! ht var(let((v(cadr ls)))(if(string? v)(lambda()(getenv v))v)))(loop(cddr ls)))))ht))(define(env-look key)((hashq-ref *env-extraction* key(lambda()(error "unrecognized key:" key)))))(define(parse-form data)(let((nv-pairs(list))(collated(list)))(for-each(lambda(pair)(define (decode . args)(url-coding:decode(apply subs pair args)))(or(string-null? pair)(let*((p(string-index pair #\=))(name(if p(decode 0 p)(decode 0)))(value(and p(decode(1+ p)))))(set! nv-pairs(acons name value nv-pairs))(set! collated(updated-alist collated name value)))))(separate-fields-discarding-char #\& data))(cons(reverse! nv-pairs)(reverse! collated))))(define(parse-form-multipart raw-data)(let((v(list))(u(list)))(define(determine-boundary s)(fs "--~A"(match:substring(string-match "boundary=\"*(.[^\"
]*)\"*" s)1)))(define(m1 m)(match:substring m 1))(define(stash-form-variable! name value)(set! v(updated-alist v name value)))(define(stash-file-upload! name filename type value raw-headers)(stash-form-variable! name filename)(set-object-property! value #:guile-www-cgi(quasiquote((#:name unquote name)(#:filename unquote filename)(#:mime-type unquote type)(#:raw-mime-headers unquote raw-headers))))(set! u(updated-alist u name value)))(let((name-exp(make-regexp "name=\"([^\"]*)\""))(filename-exp(make-regexp "filename=\"*([^\"
]*)\"*"))(type-exp(make-regexp "Content-Type: ([^
]*)
" regexp/icase))(value-exp(make-regexp "

")))(let level((str raw-data)(boundary(determine-boundary(env-look(quote content-type))))(parent-name #f))(let*((boundary-len(string-length boundary))(find-bound(lambda(start)(string-contains str boundary start))))(let get-pair((start 0))(and=>(and=>(find-bound start)(lambda(outer-seg-start)(let((seg-start(+ outer-seg-start boundary-len)))(and=>(find-bound seg-start)(lambda(seg-finish)(cons(subs str seg-start(- seg-finish 2))seg-finish))))))(lambda(segment-newstart)(let*((segment(car segment-newstart))(try(lambda(rx extract)(and=>(regexp-exec rx segment)extract)))(name(or parent-name(try name-exp m1)))(value(try value-exp match:suffix))(type(try type-exp m1)))(and name value(cond((and type(not parent-name)(string-match "multipart/mixed" type))(level value(determine-boundary type)name))((and type(try filename-exp m1))=>(lambda(filename)(stash-file-upload! name filename type value(subs(try value-exp match:prefix)2))))(else(stash-form-variable! name value)))))(get-pair(cdr segment-newstart))))))))(cons(reverse! v)(reverse! u))))(define(get-cookies raw)(let((pair-exp(make-regexp "([^=; 	
]+)=([^=; 	
