ikarus/lab/ikarus-cgi.ss

89 lines
2.5 KiB
Scheme
Executable File

#!/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))