;;; Copyright (C) 2005 FSF
;;; METAINFO: /y/people/emsley/autobuild/IRIX64-batman/share/guile/site/www/METAINFO
(define-module(www server-utils answer)#:export(mouthpiece))(define (mouthpiece out-port . status-box)(define(walk-tree proc tree)(if(pair? tree)(for-each(lambda(sub)(walk-tree proc sub))tree)(proc tree)))(and(not(null? status-box))(not(list?(car status-box)))(set! status-box(quote())))(let((reply-status #f)(header-lines(quote()))(content(quote()))(content-length #f))(define(reset-protocol!)(set! reply-status #f)(set! header-lines(quote()))(set! content(quote()))(set! content-length #f))(define(set-reply-status number msg)(or(null? status-box)(set-car!(car status-box)number))(set! reply-status(format #f "HTTP/1.0 ~A ~A
" number msg)))(define(set-reply-status:success)(set-reply-status 200 "OK"))(define(add-header name value)(set! header-lines(cons(cond((eq? #f name)(string-append value "
"))((eq? #t name)value)(else(format #f "~A: ~A
"(if(keyword? name)(keyword->symbol name)name)value)))header-lines)))(define (add-content . tree)(walk-tree(lambda(s)(set! content-length(+(or content-length 0)(string-length s))))tree)(set! content(append content tree)))(define (add-formatted fstr . args)(add-content(list(apply format #f(cond((eq? #f fstr)"~S")((eq? #t fstr)"~A")(else fstr))args))))(define(rechunk-content chunk)(define(upd! proc get-new-content)(walk-tree proc content)(set! content(get-new-content)))(cond((eq? #f chunk)(let((ls(quote())))(walk-tree(lambda(s)(set! ls(cons(string-length s)ls)))content)(reverse ls)))((eq? #t chunk)(rechunk-content content-length))((and(number? chunk)(not(< 0 chunk)))(quote()))((number? chunk)(let*((extra(remainder content-length chunk))(dreck(make-list(quotient content-length chunk)chunk))(frizz(if(= 0 extra)dreck(reverse(cons extra dreck))))(noise(map(lambda(n)(make-string n))frizz))(nw noise)(dest(car nw))(dlen(string-length dest))(wpos 0))(upd!(lambda(s)(let*((size(string-length s))(dpos(remainder wpos chunk))(left(- dlen dpos)))(let loop((start 0)(move(min size left)))(substring-move! s start(+ start move)dest dpos)(set! wpos(+ wpos move))(let((new-start(+ start move))(new-dpos(remainder wpos chunk)))(cond((= 0 new-dpos)(set! nw(cdr nw))(cond((not(null? nw))(set! dest(car nw))(set! dlen(string-length dest))))))(or(= size new-start)(begin(set! dpos new-dpos)(set! left(- dlen dpos))(loop new-start(min(- size new-start)left))))))))(lambda()noise))frizz))(else(error "chunk must be #f, #t or a number:" chunk))))(define(send-reply)(define(>OUT x)(display x out-port))(or reply-status(error "reply status not set"))(and content-length(add-header #:Content-Length content-length))(>OUT reply-status)(>OUT(apply string-append(reverse! header-lines)))(>OUT "
