(define-module(www server-utils answer)#:export(CRLF flat-length fs walk-tree tree-flat-length! string<-tree string<-headers compose-response mouthpiece)#:use-module((www crlf)#:select((CRLF . the-actual-CRLF) out!))#:use-module(ice-9 curried-definitions)#:use-module(ice-9 optargs)#:use-module((ice-9 q)#:select(make-q enq! q-empty? deq! sync-q!)))
(define-macro(+! v n) `(set!  ,v(+  ,v  ,n)))
(define CRLF the-actual-CRLF)
(define flat-length(make-object-property))
(define (fs s . args)(apply simple-format #f s args))
(define(walk-tree proc tree)(cond((null? tree))((pair? tree)(for-each(lambda(sub)(walk-tree proc sub))tree))(else(proc tree))))
(define(tree-flat-length! tree)(cond((string? tree)(string-length tree))((null? tree)0)((flat-length tree))(else(let((len(+(tree-flat-length!(car tree))(tree-flat-length!(cdr tree)))))(set!(flat-length tree)len)len))))
(define(string<-tree tree)(let((wp 0)(rv(make-string(tree-flat-length! tree))))(walk-tree(lambda(s)(let((len(string-length s)))(substring-move! s 0 len rv wp)(+! wp len)))tree)rv))
(define((ish-ref idx)ish)(vector-ref ish idx))
(define ish-eol(ish-ref 0))
(define ish-proto-v(ish-ref 1))
(define ish-status(ish-ref 2))
(define ish-kv-sep(ish-ref 3))
(define ish-neck(ish-ref 4))
(define http-ish(vector CRLF "HTTP/~A.~A " #f ": " CRLF))
(define tree<-header-proc(let((cache '()))(define(k x)(if(string? x)x(fs "~A"(if(keyword? x)(keyword->symbol x)x))))(define(v x)(if(or(string? x)(pair? x)(null? x))x(fs "~A" x)))(lambda(style)(define(trundle)(let*((one(ish-kv-sep style))(two(ish-eol style))(k-len(+(string-length one)(string-length two))))(lambda(key val)(set! key(k key))(set! val(v val))(let((tree(list key one val two)))(set!(flat-length tree)(+(string-length key)(tree-flat-length! val)k-len))tree))))(or(assq-ref cache style)(let((rv(trundle)))(set! cache(acons style rv cache))rv)))))
(define*(string<-headers alist #:optional(style #f))(string<-tree(map(tree<-header-proc(or style http-ish))(map car alist)(map cdr alist))))
(define status-format-string(let((cache '()))(lambda(protocol-version style)(define(trundle)(string-append(cond((and protocol-version(ish-proto-v style))=>(lambda(fmt)(fs fmt(car protocol-version)(cdr protocol-version))))(else ""))(or(ish-status style)"")"~A" " " "~A"(ish-eol style)))(let((key(cons protocol-version style)))(or(assoc-ref cache key)(let((rv(trundle)))(set! cache(acons key rv cache))rv))))))
(define*(compose-response host #:key(style #f)(protocol-version  '(1 . 1)))(or style(set! style http-ish))(let*((status #f)(hq(make-q))(hlen 0)(headers '())(body? #t)(direct-writers '())(entq(make-q))(lenq(make-q))(final-entity-length #f))(define tree<-header(tree<-header-proc style))(define(current-entity-length)(or final-entity-length(apply +(car lenq))))(define(walk-content proc)(walk-tree proc(car entq)))(define(set-protocol-version pair)(or(and(pair? pair)(integer?(car pair))(integer?(cdr pair)))(error "bad protocol-version:" pair))(set! protocol-version pair))(define(set-reply-status number msg)(and number msg(set! status(list number msg))))(define(add-header name value)(define(up! new)(+! hlen(tree-flat-length! new))(enq! hq new))(cond((eq? #f name)(up!(list value CRLF)))((eq? #t name)(up! value))(else(up!(tree<-header name value)))))(define(add-string s)(enq! lenq(string-length s))(enq! entq s))(define (add-content . tree)(add-string(string<-tree tree)))(define (add-formatted fstr . args)(add-string(apply fs(cond((eq? #f fstr)"~S")((eq? #t fstr)"~A")(else fstr))args)))(define*(add-direct-writer len write #:optional chunkable?)(set! direct-writers(acons write(cons len chunkable?)direct-writers))(enq! lenq len)(enq! entq(if chunkable?(lambda(port)(write port len))write)))(define(x-length x)(if(procedure? x)(car(assq-ref direct-writers x))(string-length x)))(define(rechunk-content chunk)(cond((not chunk)(car lenq))((not(null? direct-writers))(error "cannot rechunk in the presence of direct-writers"))((eq? #t chunk)(rechunk-content(current-entity-length)))((not(number? chunk))(error "bad #:rechunk-content spec:" chunk))((zero? chunk) '())(else(let*((entlen(current-entity-length))(extra(remainder entlen chunk))(dreck(make-list(quotient entlen chunk)chunk))(frizz(if(zero? extra)dreck(append! dreck(list extra))))(noise(map(lambda(n)(make-string n))frizz))(nw noise)(dest(car nw))(dlen(string-length dest))(wpos 0))(define(shift 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)(+! wpos move)(let((new-start(+ start move))(new-dpos(remainder wpos chunk)))(cond((zero? 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))))))))(walk-content shift)(set-car! entq noise)(sync-q! entq)(set-car! lenq frizz)(sync-q! lenq)frizz))))(define(inhibit-content! value)(set! body?(not value)))(define(entity-length)(if body?(current-entity-length)0))(define*(send! sock #:optional(flags '()))(or status(error "reply status not set"))(set! final-entity-length(current-entity-length))(out! sock host(lambda(k v)(string<-headers(acons k v '())style))(apply fs(status-format-string protocol-version style)status)(ish-neck style)(let((h-str(make-string hlen))(wp 0))(walk-tree(lambda(s)(let((len(string-length s)))(substring-move! s 0 len h-str wp)(+! wp len)))(car hq))(list h-str))(and body?(lambda(command)(case command((content-length)final-entity-length)((next-chunk)(if(q-empty? entq)(values #f #f)(values(deq! lenq)(deq! entq))))(else #f))))flags)(list(car status)(if body? final-entity-length 0)))(lambda (command . args)(apply(case command((#:set-protocol-version)set-protocol-version)((#:set-reply-status)set-reply-status)((#:add-header)add-header)((#:add-content)add-content)((#:add-formatted)add-formatted)((#:add-direct-writer)add-direct-writer)((#:rechunk-content)rechunk-content)((#:inhibit-content!)inhibit-content!)((#:entity-length)entity-length)((#:send!)send!)(else(error "unrecognized command:" command)))args))))
(define*(mouthpiece out-port #:optional(status-box #f)(style #f))(define protocol-version  '(1 . 0))(or(list? status-box)(set! status-box #f))(or style(set! style http-ish))(let((partial #f))(define(reset-protocol!)(set! partial(compose-response(or(gethostname)"localhost")#:protocol-version protocol-version #:style style)))(define(set-reply-status:success)(partial #:set-reply-status 200 "OK"))(define*(send-reply #:optional close)(let((rv(partial #:send! out-port)))(force-output out-port)(reset-protocol!)(cond(close(and(eq?  'socket(port-filename out-port))(shutdown out-port(if(thunk? close)(close)close)))(set! out-port #f)))(cond(status-box(set-car! status-box(car rv))(cond((pair?(cdr status-box))(set-car!(cdr status-box)(cadr rv))))))rv))(reset-protocol!)(lambda (command . args)(or(keyword? command)(error "command not a keyword:" command))(if(memq command '(#:set-reply-status #:add-header #:add-content #:add-formatted #:add-direct-writer #:content-length #:rechunk-content #:inhibit-content!))(apply partial command args)(apply(case command((#:reset-protocol!)reset-protocol!)((#:set-reply-status:success)set-reply-status:success)((#:send-reply)send-reply)(else(error "unrecognized command:" command)))args)))))
