89 lines
2.5 KiB
Scheme
89 lines
2.5 KiB
Scheme
|
#!/usr/bin/env ikarus --r6rs-script
|
||
|
|
|
||
|
|
(import (ikarus))
|
||
|
|
|
||
|
|
(define (get-headers ip escape)
|
||
|
|
(let f ([ls '()])
|
||
|
|
(let ([key (get-line ip)])
|
||
|
|
(cond
|
||
|
|
[(eof-object? key) (escape)]
|
||
|
|
[(string=? key "end") ls]
|
||
|
|
[else
|
||
|
|
(let ([val (get-line ip)])
|
||
|
|
(when (eof-object? val) (escape))
|
||
|
|
(f (cons (cons key val) ls)))]))))
|
||
|
|
|
||
|
|
(define (put-headers ls op)
|
||
|
|
(for-each
|
||
|
|
(lambda (p)
|
||
|
|
(display (car p) op)
|
||
|
|
(newline op)
|
||
|
|
(display (cdr p) op)
|
||
|
|
(newline op))
|
||
|
|
ls)
|
||
|
|
(display "end\n" op))
|
||
|
|
|
||
|
|
(define (alist->string ls)
|
||
|
|
(let-values ([(p e) (open-string-output-port)])
|
||
|
|
(for-each
|
||
|
|
(lambda (x)
|
||
|
|
(fprintf p "~s => ~s\n" (car x) (cdr x)))
|
||
|
|
ls)
|
||
|
|
(e)))
|
||
|
|
|
||
|
|
(define (serve-client ip op)
|
||
|
|
(call/cc
|
||
|
|
(lambda (k)
|
||
|
|
(with-exception-handler
|
||
|
|
(lambda (con)
|
||
|
|
(cond
|
||
|
|
[(interrupted-condition? con)
|
||
|
|
(raise-continuable con)]
|
||
|
|
[else
|
||
|
|
(print-condition con (current-error-port))
|
||
|
|
(k)]))
|
||
|
|
(lambda ()
|
||
|
|
(let loop ()
|
||
|
|
(let* ([headers (get-headers ip k)]
|
||
|
|
[response (alist->string headers)])
|
||
|
|
(put-headers
|
||
|
|
`(("Content-type" . "text/plain")
|
||
|
|
("Keep-Socket" . "1")
|
||
|
|
("Content-length" . ,(string-length response)))
|
||
|
|
op)
|
||
|
|
(display response op)
|
||
|
|
(flush-output-port op))
|
||
|
|
(loop)))))))
|
||
|
|
|
||
|
|
(define cgi-server
|
||
|
|
(case-lambda
|
||
|
|
[(who port)
|
||
|
|
(let ([s (tcp-server-socket-nonblocking
|
||
|
|
(or (string->number port)
|
||
|
|
(error who "invalid port number" port)))])
|
||
|
|
(printf "Listening on port ~a\n" port)
|
||
|
|
(call/cc
|
||
|
|
(lambda (k)
|
||
|
|
(with-exception-handler
|
||
|
|
(lambda (con)
|
||
|
|
(print-condition con)
|
||
|
|
(k))
|
||
|
|
(lambda ()
|
||
|
|
(let f ()
|
||
|
|
(let-values ([(op ip)
|
||
|
|
(accept-connection-nonblocking s)])
|
||
|
|
(printf "got a connection\n")
|
||
|
|
(let ([op (transcoded-port op (native-transcoder))]
|
||
|
|
[ip (transcoded-port ip (native-transcoder))])
|
||
|
|
(register-callback op
|
||
|
|
(lambda () (serve-client ip op)))))
|
||
|
|
(f))))))
|
||
|
|
(printf "\nClosing server ...\n")
|
||
|
|
(close-tcp-server-socket s))]
|
||
|
|
[(who)
|
||
|
|
(error who "missing port number")]
|
||
|
|
[(who . args)
|
||
|
|
(error who "too many arguments")]))
|
||
|
|
|
||
|
|
(apply cgi-server (command-line))
|