(define-module(www server-utils big-dishing-loop)#:export(named-socket echo-upath make-big-dishing-loop)#:use-module(ice-9 optargs)#:use-module((www server-utils parse-request)#:select(request-method request-upath request-headers receive-request))#:use-module((www server-utils answer)#:select(mouthpiece)))
(define*(named-socket family name #:key(socket-setup #f))(let((new(socket family SOCK_STREAM 0)))((cond((not socket-setup)identity)((procedure? socket-setup)socket-setup)((list? socket-setup)(lambda(sock)(for-each(lambda(pair)(setsockopt sock SOL_SOCKET(car pair)(cdr pair)))socket-setup)))(else(error "bad socket-setup:" socket-setup)))new)(apply bind new name)new))
(define (echo-upath M upath . extra-args)(M #:set-reply-status:success)(M #:add-header  'Connection "close")(M #:add-header  'Content-Type "text/plain")(M #:add-content upath "\n")(for-each(lambda(arg)(M #:add-formatted "extra-arg: ~S~%" arg))extra-args)(M #:send-reply 2)#t)
(define http-hgrok(vector #f #f))
(define*(make-big-dishing-loop #:key(socket-setup #f)(style #f)(need-headers #f)(need-input-port #f)(explicit-return #f)(method-handlers '())(unknown-http-method-handler #f)(status-box-size #f)(loop-break-bool #f)(queue-length 0)(bad-request-handler #f)(concurrency #:new-process)(parent-finish close-port)(log #f))(define(parse port)(catch  'parse-error(lambda()(receive-request port #:s2s identity #:style style))(lambda(k prob obj)#f)))(or style(set! style http-hgrok))(let()(define(bdlcore queue-length sock handle-request)(listen sock queue-length)(let loop((conn(accept sock)))(and(handle-request conn(parse(car conn)))(loop(accept sock)))))(define(good conn req)(let*((p(car conn))(method(request-method req))(upath(request-upath req))(h(and need-headers(map(lambda(pair)(cons(symbol->string(car pair))(cdr pair)))(request-headers req))))(b(and(number? status-box-size)(make-list status-box-size #f)))(M(mouthpiece p b(vector-ref style 1)))(res(cond((assq-ref method-handlers method)=>(lambda(mh)(call-with-current-continuation(lambda(k)(apply mh M upath(append(if need-headers(list h) '())(if need-input-port(list p) '())(if explicit-return(list k) '())))(not loop-break-bool)))))(unknown-http-method-handler =>(lambda(umh)(umh M method upath)))(else(not loop-break-bool)))))(and log(log(let*((sock(cdr conn))(fam(sockaddr:fam sock)))(cond((= PF_INET fam)(let((addr(sockaddr:addr sock))(port(sockaddr:port sock)))(simple-format #f "~A:~A"(cond-expand(guile-2(inet-ntop AF_INET addr))(else(inet-ntoa addr)))port)))((= PF_UNIX fam)(let((fn(sockaddr:path sock)))(if(or(not fn)(string-null? fn))"localhost" fn)))(else(object->string sock))))method upath b))(not(eq? loop-break-bool res))))(lambda(ear)(bdlcore queue-length(if(port? ear)ear(let((int?(integer? ear)))(or int?(pair? ear)(error "bad ear:" ear))(named-socket(if int? PF_INET(car ear))(if int?(list AF_INET INADDR_ANY ear)(cdr ear))#:socket-setup socket-setup)))(lambda(conn req)(let((p(car conn)))(define(child)(let((rv(cond(req(good conn req))(bad-request-handler(bad-request-handler(mouthpiece p)))(else(not loop-break-bool)))))(or need-input-port(shutdown p 2))rv))(case concurrency((#:new-process #:new-process/nowait)(let((pid(primitive-fork)))(cond((zero? pid)(exit(child)))(else(parent-finish p)(set! p #f)(or(eq? #:new-process/nowait concurrency)(zero?(status:exit-val(cdr(waitpid pid)))))))))(else(child)))))))))
