;;; Copyright (C) 2005 FSF
;;; METAINFO: /y/people/emsley/autobuild/IRIX64-batman/share/guile/site/www/METAINFO
(define-module(www http)#:use-module(www url)#:use-module(ice-9 regex)#:export(http:message-version http:message-status-code http:message-status-text http:message-status-ok? http:status-ok? http:message-body http:message-headers http:message-header http:head http:get http:post-form http:open http:request))(or(defined?(quote read-line))(use-modules(ice-9 rdelim)))(define subs make-shared-substring)(define http:version "HTTP/1.0")(define(http:make-message version statcode stattext headers body)(vector version statcode stattext headers body))(define(http:message-version msg)(vector-ref msg 0))(define(http:message-status-code msg)(vector-ref msg 1))(define(http:message-status-text msg)(vector-ref msg 2))(define(http:message-status-ok? msg)(http:status-ok?(http:message-status-code msg)))(define(http:status-ok? status)(char=? #\2(string-ref status 0)))(define(http:message-body msg)(vector-ref msg 4))(define(http:message-headers msg)(vector-ref msg 3))(define(http:message-header header msg)(http:fetch-header header(http:message-headers msg)))(define(http:fetch-header header header-alist)(assq-ref header-alist header))(define header-regex(make-regexp ": *"))(define(http:header-parse hd)(let((match(regexp-exec header-regex hd)))(cons(string->symbol(apply string(map char-downcase(string->list(match:prefix match)))))(match:suffix match))))(define(parse-status-line statline)(let*((first(string-index statline #\space))(second(string-index statline #\space(1+ first))))(list(subs statline 0 first)(subs statline(1+ first)(or second(string-length statline)))(if second(subs statline(1+ second))""))))(define connection-table(quote()))(define(add-open-connection! host tcp-port port)#f)(define(get-open-connection host tcp-port)#f)(define(http:head url)(http:request "HEAD" url(list(string-append "Host: "(url:host url)))))(define(http:get url)(http:request "GET" url(list(string-append "Host: "(url:host url)))))(define(http:post-form url extra-headers fields)(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(and(procedure? source)(equal?(quote(0 0 #f))(procedure-property source(quote arity))))(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 (c-type type . boundary)(format #f "Content-Type: ~A~A" type(if(null? boundary)""(format #f "; boundary=~S"(car boundary)))))(define (c-disp disp name . f?)(format #f "Content-Disposition: ~A; ~Aname=\"~A\"" disp(if(null? f?)"" "file")name))(let((simple(quote()))(uploads(quote()))(boundary "gUiLeWwWhTtPpOsTfOrM"))(for-each(lambda(field)(if(pair?(cdr field))(begin(for-each validate-upload-spec(cdr field))(set! uploads(cons field uploads)))(set! simple(cons field simple))))fields)(set! simple(reverse! simple))(set! uploads(reverse! uploads))(http:request "POST" url(append(list(if(null? uploads)(c-type "application/x-www-form-urlencoded")(c-type "multipart/form-data" boundary))(format #f "Host: ~A"(url:host url)))extra-headers)(if(null? uploads)(or(and(null? simple)simple)(let*((enc(lambda(extract pair)(url:encode(extract pair)(quote()))))(one(lambda(fmt pair)(format #f fmt(enc car pair)(enc cdr pair)))))(list(apply string-append(one "~A=~A"(car simple))(map(lambda(field)(one "&~A=~A" field))(cdr simple))))))(let((boundary-line(string-append "--" boundary))(aam(lambda(proc ls)(apply append(map proc ls)))))(quasiquote((unquote-splicing(aam(lambda(pair)(list boundary-line(c-disp "form-data"(car pair))""(cdr pair)))simple))(unquote-splicing(aam(lambda(name-spec)(let*((sub-b(string-append "SuB" boundary))(sub-b-line(string-append "--" sub-b)))(quasiquote((unquote boundary-line)(unquote(c-disp "form-data"(car name-spec)))(unquote(c-type "multipart/mixed" sub-b))""(unquote-splicing(quasiquote((unquote-splicing(aam(lambda(spec)(list sub-b-line(c-disp "attachment"(basename(#{name:}# spec))#t)(c-type(#{mime-type:}# spec))(format #f "Content-Transfer-Encoding: ~A"(#{xfer-enc:}# spec))""(let((s(#{source:}# spec)))(if(string? s)s(s)))))(cdr name-spec))))))(unquote(string-append sub-b-line "--"))))))uploads))(unquote(string-append boundary-line "--")))))))))(define (http:open host . args)(let((port(cond((null? args)80)((not(car args))80)(else(car args)))))(or(get-open-connection host port)(let*((tcp(vector-ref(getproto "tcp")2))(addr(car(vector-ref(gethost host)4)))(sock(socket AF_INET SOCK_STREAM tcp)))(connect sock AF_INET addr port)(add-open-connection! host port sock)sock))))(define form-hack-regex(make-regexp "content-type: *application/x-www-form-urlencoded" regexp/icase))(define (http:request method url . args)(let((host(url:host url))(tcp-port(or(url:port url)80))(path(format #f "/~A"(or(url:path url)""))))(let((sock(http:open host tcp-port))(request(format #f "~A ~A ~A" method path http:version))(headers(cons(format #f "Host: ~A"(url:host url))(if(pair? args)(car args)(quote()))))(body(if(and(pair? args)(pair?(cdr args)))(cadr args)(quote()))))(let*((form-hack?(let loop((ls headers))(cond((null? ls)#f)((regexp-exec form-hack-regex(car ls))(and(pair? body)(not(pair?(cdr body)))))(else(loop(cdr ls))))))(content-length(apply +(if form-hack? -2 0)(map(lambda(line)(+ 2(string-length line)))body)))(headers(if(positive? content-length)(cons(format #f "Content-Length: ~A" content-length)headers)headers)))(with-output-to-port sock(lambda()(display-with-crlf request)(for-each display-with-crlf headers)(display "
")(if form-hack?(display(car body))(for-each display-with-crlf body))))(let*((response-status-line(sans-trailing-whitespace(read-line sock(quote trim))))(response-headers(let make-header-list((ln(sans-trailing-whitespace(read-line sock(quote trim))))(hlist(quote())))(if(= 0(string-length ln))hlist(make-header-list(sans-trailing-whitespace(read-line sock(quote trim)))(cons(http:header-parse ln)hlist)))))(response-status-fields(parse-status-line response-status-line))(response-version(car response-status-fields))(response-code(cadr response-status-fields))(response-text(caddr response-status-fields)))(let((content-length(http:fetch-header(quote content-length)response-headers)))(let((response-body(if(and content-length(not(string-ci=? method "HEAD")))(read-n-chars(string->number content-length)sock)(with-output-to-string(lambda()(while(not(eof-object?(peek-char sock)))(display(read-char sock))))))))(close-port sock)(http:make-message response-version response-code response-text response-headers response-body))))))))(define (read-n-chars num . port-arg)(let((p(if(null? port-arg)(current-input-port)(car port-arg)))(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 (display-with-crlf line . p)(apply display line p)(apply display "
