added a cgi-server example to lab.

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))