diff --git a/lab/ikarus-cgi.ss b/lab/ikarus-cgi.ss new file mode 100755 index 0000000..05a0758 --- /dev/null +++ b/lab/ikarus-cgi.ss @@ -0,0 +1,88 @@ +#!/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))