(define-module(www http)#:export(protocol-version 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:post-form http:connect http:open send-request receive-response http:request)#:use-module((www crlf)#:select(read-three-part-line hsym-proc read-headers/get-body out!))#:autoload(www post)(formatted-form-for-http:post-form)#:use-module((srfi srfi-1)#:select(car+cdr))#:use-module((srfi srfi-11)#:select(let-values))#:use-module((srfi srfi-13)#:select(string-titlecase))#:use-module((www url)#:select(url:host url:port url:path))#:use-module(ice-9 optargs))
(define (fs s . args)(apply simple-format #f s args))
(define protocol-version(make-fluid))
(fluid-set! protocol-version  '(1 . 0))
(define(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)(= 2(quotient(if(string? status)(string->number status)status)100)))
(define(http:message-body msg)(vector-ref msg 4))
(define(http:message-headers msg)(vector-ref msg 3))
(define(http:message-header header msg)(assq-ref(http:message-headers msg)header))
(define(msg-headers! msg alist)(vector-set! msg 3 alist))
(define(msg-body! msg string)(vector-set! msg 4 string))
(define(msg-string-rcode! msg)(vector-set! msg 1(number->string(vector-ref msg 1))))
(define(http:post-form url extra-headers fields)(let-values(((headers body)(formatted-form-for-http:post-form fields)))(http:request  'POST url(append headers extra-headers)body)))
(define (http:connect proto addrfam address . address-rest)(let((sock(socket proto SOCK_STREAM 0)))(apply connect sock addrfam address address-rest)sock))
(define*(http:open host #:optional(port 80))(http:connect PF_INET AF_INET(car(hostent:addr-list(gethost host)))port))
(define*(send-request sock method url #:key(headers '())body(flags '())(protocol-version  '(1 . 1)))(define(chunked!)(set! flags(cons  'chunked flags)))(let-values(((major minor)(car+cdr protocol-version)))(define (h+! . more)(set! headers(append more headers)))(cond((and(= 1 major)(positive? minor))(chunked!)(h+! "TE: trailers" "Connection: TE")))(out! sock(url:host url)method(fs "/~A"(or(url:path url)""))(fs "HTTP/~A.~A" major minor)headers body flags))(lambda(s2s)(let-values(((rvers rcode rtext)(read-three-part-line sock)))(let((numeric(string->number rcode)))(let-values(((headers body)(read-headers/get-body sock s2s(lambda()(values method numeric)))))(make-message rvers numeric rtext headers body))))))
(define*(receive-response pending #:key(s2s string-titlecase)intervene(flags '()))(let((msg(pending s2s)))(define(h-maybe! x)(and x(msg-headers! msg x)))(define(intervene!)(define hget(let((headers(http:message-headers msg))(hsym(hsym-proc s2s)))(lambda(sel)(cond((not sel)headers)((eq? #t sel)hsym)(else(assq-ref headers(if(string? sel)(hsym sel)sel)))))))(let-values(((new-headers new-flags)(intervene hget flags)))(h-maybe! new-headers)(and new-flags(set! flags new-flags))))(and=>(http:message-body msg)(lambda(get-body)(and intervene(intervene!))(let-values(((new-headers s)(get-body flags)))(h-maybe! new-headers)(msg-body! msg s))))msg))
(define*(http:request method url #:optional(headers '())(body '()))(cond((symbol? method))((string? method)(set! method(string->symbol method)))(else(error "bad method:" method)))(let*((sock(http:open(url:host url)(or(url:port url)80)))(get(send-request sock method url #:headers headers #:body body #:protocol-version(fluid-ref protocol-version)))(ans(receive-response get #:s2s string-downcase)))(msg-string-rcode! ans)(close-port sock)ans))
