thread-support merged

cgi-server.scm

@@ -99,7 +99,7 @@
 	       (nph? (string-suffix? "-nph" prog))	; PROG end in "-nph" ? 
 
 	       (search (http-url:search (request:url req)))	; Compute the
-	       (argv (if (and search (not (index search #\=)))	; argv list.
+	       (argv (if (and search (not (string-index search #\=)))	; argv list.
 		         (split-and-decode-search-spec search)
 		         '()))
 
@@ -125,7 +125,7 @@
 
 (define (split-and-decode-search-spec s)
   (let recur ((i 0))
-    (? ((index s #\+ i) => (lambda (j) (cons (unescape-uri s i j)
+    (? ((string-index s #\+ i) => (lambda (j) (cons (unescape-uri s i j)
 					     (recur (+ j 1)))))
        (else (list (unescape-uri s i (string-length s)))))))
 
@@ -182,7 +182,7 @@
 	  ("SCRIPT_NAME"     . ,script-name)
 
 	  ("REMOTE_HOST"  . ,(host-info:name (host-info raddr)))
-	  ("REMOTE_ADDR"  . ,(internet-address->dotted-string rhost))
+	  ("REMOTE_ADDR"  . ,(internet-host-address->dotted-string rhost))
 
 	  ;; ("AUTH_TYPE" . xx)			; Random authentication
 	  ;; ("REMOTE_USER" . xx)		; features I don't understand.
@@ -265,15 +265,3 @@
       (close-input-port script-port))))
 
 
-;;; This proc and its inverse should be in a general IP module.
-
-(define (internet-address->dotted-string num32)
-  (let* ((num24 (arithmetic-shift num32 -8))
-	 (num16 (arithmetic-shift num24 -8))
-	 (num08 (arithmetic-shift num16 -8))
-	 (byte0 (bitwise-and #b11111111 num08))
-	 (byte1 (bitwise-and #b11111111 num16))
-	 (byte2 (bitwise-and #b11111111 num24))
-	 (byte3 (bitwise-and #b11111111 num32)))
-    (string-append (number->string byte0) "." (number->string byte1) "."
-		   (number->string byte2) "." (number->string byte3))))

crlf-io.scm

@@ -36,4 +36,18 @@
   (write-string "\r\n" port)
   (force-output port))
 
+(define (read-crlf-line-timeout . args)
+  (let-optionals args ((fd/port (current-input-port))
+		       (retain-crlf? #f)
+		       (timeout 8000)
+		       (max-interval 500))
+   (let loop ((waited 0) (interval 100))
+     (cond ((> waited timeout)
+	    'timeout)
+	   ((char-ready? fd/port)
+	    (read-crlf-line fd/port retain-crlf?))
+	   (else (sleep interval)
+		 (loop (+ waited interval) (min (* interval 2)
+						max-interval)))))))
+		 
 		 

ftpd.scm

@@ -10,6 +10,62 @@
 ; - Banners from files on CWD
 ; - Lots of fancy stuff like ProFTPD, http://www.proftpd.org/
 
+
+(define-record session
+  control-input-port
+  control-output-port
+  (logged-in? #f)
+  (authenticated? #f)
+  (anonymous? #f)
+  (root-directory #f)
+  (current-directory "")
+  (to-be-renamed #f)
+  (reverse-replies '())
+  (reply-code #f) ; the last one wins
+  (type 'ascii)       ; PLEASE set this to bin 
+  (data-socket #f)
+  (passive-socket #f))
+
+(define session (make-fluid #f))
+
+(define (make-fluid-selector selector)
+  (lambda () (selector (fluid session))))
+
+(define (make-fluid-setter setter)
+  (lambda (value)
+    (setter (fluid session) value)))
+
+	
+(define session-control-input-port (make-fluid-selector session:control-input-port))
+(define session-control-output-port (make-fluid-selector session:control-output-port))
+(define session-logged-in? (make-fluid-selector session:logged-in?))
+(define session-authenticated? (make-fluid-selector session:authenticated?))
+(define session-anonymous? (make-fluid-selector session:anonymous?))
+(define session-root-directory (make-fluid-selector session:root-directory))
+(define session-current-directory (make-fluid-selector session:current-directory))
+(define session-to-be-renamed (make-fluid-selector session:to-be-renamed))
+(define session-reverse-replies (make-fluid-selector session:reverse-replies))
+(define session-reply-code (make-fluid-selector session:reply-code))
+(define session-type (make-fluid-selector session:type))
+(define session-data-socket (make-fluid-selector session:data-socket)) 
+(define session-passive-socket (make-fluid-selector session:passive-socket))
+
+(define set-session-control-input-port 
+  (make-fluid-setter set-session:control-input-port))
+(define set-session-control-output-port 
+  (make-fluid-setter set-session:control-output-port))
+(define set-session-logged-in? (make-fluid-setter set-session:logged-in?))
+(define set-session-authenticated? (make-fluid-setter set-session:authenticated?))
+(define set-session-anonymous? (make-fluid-setter set-session:anonymous?))
+(define set-session-root-directory (make-fluid-setter set-session:root-directory))
+(define set-session-current-directory (make-fluid-setter set-session:current-directory))
+(define set-session-to-be-renamed (make-fluid-setter set-session:to-be-renamed))
+(define set-session-reverse-replies (make-fluid-setter set-session:reverse-replies))
+(define set-session-reply-code (make-fluid-setter set-session:reply-code))
+(define set-session-type (make-fluid-setter set-session:type))
+(define set-session-data-socket (make-fluid-setter set-session:data-socket)) 
+(define set-session-passive-socket (make-fluid-setter set-session:passive-socket))
+	
 (define (ftpd . maybe-port)
   (let ((port (optional maybe-port 21)))
     (bind-listen-accept-loop
@@ -18,11 +74,10 @@
        
        (set-ftp-socket-options! socket)
        
-       (fork
+       (spawn
 	(lambda () 
 	  (handle-connection (socket:inport socket) 
 			     (socket:outport socket))
-	  (reap-zombies)
 	  (shutdown-socket socket shutdown/sends+receives))))
      
      port)))
@@ -34,26 +89,23 @@
 (define (set-ftp-socket-options! socket)
   ;; If the client closes the connection, we won't lose when we try to
   ;; close the socket by trying to flush the output buffer.
-  (set-port-buffering (socket:outport socket) bufpol/none)
+  (set-port-buffering (socket:outport socket) 'bufpol/none)
 
   (set-socket-option socket level/socket socket/oob-inline #t))
 
-; We're stateful anyway, so what the hell ...
-
-(define *control-input-port* #f)
-(define *control-output-port* #f)
 
 (define (handle-connection input-port output-port)
   (call-with-current-continuation
    (lambda (escape)
      (with-handler
       (lambda (condition more)
+	(display condition (current-error-port))
 	(escape 'fick-dich-ins-knie))
       (lambda ()
-	(set! *control-input-port* input-port)
+	(let-fluid session (make-session input-port output-port)
-	(set! *control-output-port* output-port)
+		   (lambda ()
 		     (display-banner)
-	(handle-commands))))))
+		     (handle-commands))))))))
 
 (define (display-banner)
   (register-reply! 220
@@ -68,6 +120,7 @@
 (define-condition-type 'ftpd-error '())
 (define ftpd-error? (condition-predicate 'ftpd-error))
 
+
 (define (handle-commands)
   (with-handler
    (lambda (condition more)
@@ -81,12 +134,21 @@
        (loop)))))
 
 (define (accept-command)
-  (let ((command-line (read-crlf-line *control-input-port*)))
+  (let ((command-line (read-crlf-line-timeout (session-control-input-port)
+					      #f
+					      90000     ; timeout
+					      500)))    ; max interval
     ;; (format #t "Command line: ~A~%" command-line)
+     (cond ((eq? command-line 'timeout)
+	    (register-reply! 
+	     421
+	     "Timeout (900 seconds): closing control connection.")
+	    (signal 'ftpd-quit))
+	   (else
 	    (call-with-values
 	     (lambda () (parse-command-line command-line))
 	     (lambda (command arg)
-       (handle-command command arg)))))
+	       (handle-command command arg)))))))
 
 (define (handle-command command arg)
   (call-with-current-continuation
@@ -125,15 +187,10 @@
 			  "."
 			  (format #f " (argument(s) \"~A\")." arg)))))))
 
-(define *logged-in?* #f)
-(define *authenticated?* #f)
-(define *anonymous?* #f)
-(define *root-directory* #f)
-(define *current-directory* "")
 
 (define (handle-user name)
   (cond
-   (*logged-in?*
+   ((session-logged-in?)
     (register-reply! 230
 		     "You are already logged in."))
    ((or (string=? "anonymous" name)
@@ -144,24 +201,24 @@
 		     "Only anonymous logins allowed."))))
 
 (define (handle-user-anonymous)
-  (let ((ftp-info (user-info "ftp")))
+  (let ((ftp-info (user-info "gasbichl")))
 
     (set-gid (user-info:gid ftp-info))
     (set-uid (user-info:uid ftp-info))
 
-    (set! *logged-in?* #t)
+    (set-session-logged-in? #t)
-    (set! *authenticated?* #t)
+    (set-session-authenticated? #t)
-    (set! *anonymous?* #t)
+    (set-session-anonymous? #t)
-    (set! *root-directory* (file-name-as-directory (user-info:home-dir ftp-info)))
+    (set-session-root-directory (file-name-as-directory (user-info:home-dir ftp-info)))
-    (set! *current-directory* "")
+    (set-session-current-directory "")
 
     (register-reply! 230 "Anonymous user logged in.")))
 
 (define (handle-pass password)
   (cond
-   ((not *logged-in?*)
+   ((not (session-logged-in?))
     (register-reply! 530 "You have not logged in yet."))
-   (*anonymous?*
+   ((session-anonymous?)
     (register-reply! 200 "Thank you."))
    (else
     (register-reply! 502 "This can't happen."))))
@@ -185,9 +242,9 @@
      (lambda ()
        (with-cwd*
 	(file-name-as-directory
-	 (string-append *root-directory* current-directory))
+	 (string-append (session-root-directory) current-directory))
 	(lambda ()			; I hate gratuitous syntax
-	  (set! *current-directory* current-directory)
+	  (set-session-current-directory current-directory)
 	  (register-reply! 250
 			   (format #f "Current directory changed to \"/~A\"."
 				   current-directory))))))))
@@ -199,7 +256,7 @@
   (ensure-authenticated-login)
   (register-reply! 257
 		   (format #f "Current directory is \"/~A\"."
-			   *current-directory*)))
+			   (session-current-directory))))
 
 
 (define (make-file-action-handler error-format-string action)
@@ -207,7 +264,7 @@
     (ensure-authenticated-login)
     (if (string=? "" path)
 	(signal-error! 500 "No argument."))
-    (let ((full-path (string-append *root-directory*
+    (let ((full-path (string-append (session-root-directory)
 				    (assemble-path path))))
       (with-errno-handler*
        (lambda (errno packet)
@@ -249,7 +306,6 @@
      (register-reply! 250
 		      (format #f "Deleted directory \"~A\"." path)))))
 
-(define *to-be-renamed* #f)
 
 (define handle-rnfr
   (make-file-action-handler
@@ -257,15 +313,15 @@
    (lambda (path full-path)
      (file-info full-path)
      (register-reply! 350 "RNFR accepted.  Gimme a RNTO next.")
-     (set! *to-be-renamed* full-path))))
+     (set-session-to-be-renamed full-path))))
 
 (define (handle-rnto path)
   (ensure-authenticated-login)
-  (if (not *to-be-renamed*)
+  (if (not (session-to-be-renamed))
       (signal-error! 503 "Need RNFR before RNTO."))
   (if (string=? "" path)
       (signal-error! 500 "No argument."))
-  (let ((full-path (string-append *root-directory*
+  (let ((full-path (string-append (session-root-directory)
 				  (assemble-path path))))
 
     (if (file-exists? full-path)
@@ -279,9 +335,9 @@
        (signal-error! 550
 		      (format #f "Could not rename: ~A." path)))
      (lambda ()
-       (rename-file *to-be-renamed* full-path)
+       (rename-file full-path)
        (register-reply! 250 "File renamed.")
-       (set! *to-be-renamed* #f)))))
+       (set-session-to-be-renamed #f)))))
   
 (define handle-size
   (make-file-action-handler
@@ -294,23 +350,22 @@
 				  path)))
        (register-reply! 213 (number->string (file-info:size info)))))))
 
-(define *type* 'ascii)
 
 (define (handle-type arg)
   (cond
    ((string-ci=? "A" arg)
-    (set! *type* 'ascii))
+    (set-session-type 'ascii))
    ((string-ci=? "I" arg)
-    (set! *type* 'image))
+    (set-session-type 'image))
    ((string-ci=? "L8" arg)
-    (set! *type* 'image))
+    (set-session-type 'image))
    (else
     (signal-error! 504
 		   (format #f "Unknown TYPE: ~A." arg))))
 
   (register-reply! 200
 		   (format #f "TYPE is now ~A."
-			   (case *type*
+			   (case (session-type)
 			     ((ascii) "ASCII")
 			     ((image) "8-bit binary")
 			     (else "somethin' weird, man")))))
@@ -360,10 +415,7 @@
 			      "Invalid arguments to PORT."))
 	   (apply
 	    (lambda (a1 a2 a3 a4 p1 p2)
-	      (values (+ (arithmetic-shift a1 24)
+	      (values (internet-host-address-from-bytes a1 a2 a3 a4)
-			 (arithmetic-shift a2 16)
-			 (arithmetic-shift a3 8)
-			 a4)
 		      (+ (arithmetic-shift p1 8)
 			 p2)))
 	    components))))
@@ -371,7 +423,6 @@
     (signal-error! 500
 		   "Syntax error in argument to PORT."))))
 
-(define *data-socket* #f)
 
 (define (handle-port stuff)
   (ensure-authenticated-login)
@@ -388,14 +439,13 @@
 		       (internet-address->socket-address
 			address port))
        
-       (set! *data-socket* socket)
+       (set-session-data-socket socket)
 
        (register-reply! 200
 			(format #f "Connected to ~A, port ~A."
 				(format-internet-host-address address)
 				port))))))
 
-(define *passive-socket* #f)
 
 (define (handle-pasv stuff)
   (ensure-authenticated-login)
@@ -417,7 +467,7 @@
        (lambda () (socket-address->internet-address address))
        (lambda (host-address port)
 
-	 (set! *passive-socket* socket)
+	 (set-session-passive-socket socket)
 
 	 (register-reply! 227
 			  (format #f "Passive mode OK (~A,~A)"
@@ -432,16 +482,12 @@
   (car (host-info:addresses (host-info (system-name)))))
 
 (define (format-internet-host-address address . maybe-separator)
-
-  (define (extract shift)
-    (number->string
-     (bitwise-and (arithmetic-shift address (- shift))
-		  255)))
-
   (let ((separator (optional maybe-separator ".")))
+    (apply (lambda (b1 b2 b3 b4)
 	     (string-append
-     (extract 24) separator (extract 16) separator
+	      b1 separator b2 separator
-     (extract 8) separator (extract 0))))
+	      b3 separator b4))
+	   (map number->string (internet-host-address-to-bytes address)))))
     
 (define (format-port port)
   (string-append
@@ -487,7 +533,7 @@
 ; ENSURE-DATA-CONNECTION.
 
 (define (generate-listing path flags)
-  (let ((full-path (string-append *root-directory*
+  (let ((full-path (string-append (session-root-directory)
 				  (assemble-path path))))
     (with-errno-handler*
      (lambda (errno packet)
@@ -496,7 +542,8 @@
 			      path
 			      (car packet))))
      (lambda ()
-       (ls flags (list full-path) (socket:outport *data-socket*))))))
+       (ls flags (list full-path) (socket:outport 
+				   (session-data-socket)))))))
 
 (define (handle-abor foo)
   (maybe-close-data-connection)
@@ -504,7 +551,7 @@
 
 (define (handle-retr path)
   (ensure-authenticated-login)
-  (let ((full-path (string-append *root-directory*
+  (let ((full-path (string-append (session-root-directory)
 				  (assemble-path path))))
     (with-fatal-error-handler*		; CALL-WITH-INPUT-FILE doesn't go through ERRNO
      (lambda (condition more)
@@ -521,19 +568,19 @@
 	   (lambda (file-port)
 	     (with-data-connection
 	      (lambda ()
-		(case *type*
+		(case (session-type)
 		  ((image)
 		   (copy-port->port-binary
 		    file-port
-		    (socket:outport *data-socket*)))
+		    (socket:outport (session-data-socket))))
 		  ((ascii)
 		   (copy-port->port-ascii
 		    file-port
-		    (socket:outport *data-socket*)))))))))))))
+		    (socket:outport (session-data-socket))))))))))))))
 
 (define (handle-stor path)
   (ensure-authenticated-login)
-  (let ((full-path (string-append *root-directory*
+  (let ((full-path (string-append (session-root-directory)
 				  (assemble-path path))))
     (with-fatal-error-handler*
      (lambda (condition more)
@@ -545,20 +592,21 @@
 	 (lambda (file-port)
 	   (with-data-connection
 	    (lambda ()
-	      (case *type*
+	      (case (session-type)
 		((image)
 		 (copy-port->port-binary
-		  (socket:inport *data-socket*)
+		  (socket:inport (session-data-socket))
 		  file-port))
 		((ascii)
 		 (copy-ascii-port->port
-		  (socket:inport *data-socket*)
+		  (socket:inport (session-data-socket))
 		  file-port)))))))))))
   
 (define (assemble-path path)
   (let* ((interim-path
 	  (if (not (file-name-rooted? path))
-	      (string-append (file-name-as-directory *current-directory*)
+	      (string-append (file-name-as-directory 
+			      (session-current-directory))
 			     path)
 	      path))
 	 (complete-path (if (file-name-rooted? interim-path)
@@ -571,8 +619,8 @@
       (signal-error! 501 "Invalid pathname")))))
 
 (define (ensure-authenticated-login)
-  (if (or (not *logged-in?*)
+  (if (or (not (session-logged-in?))
-	  (not *authenticated?*))
+	  (not (session-authenticated?)))
       (signal-error! 530 "You're not logged in yet.")))
 
 (define (with-data-connection thunk)
@@ -583,35 +631,36 @@
 (define *window-size* 51200)
 
 (define (ensure-data-connection)
-  (if (and (not *data-socket*) (not *passive-socket*))
+  (if (and (not (session-data-socket)) 
+	   (not (session-passive-socket)))
       (signal-error! 425 "No data connection."))
 
-  (if *passive-socket*
+  (if (session-passive-socket)
       (call-with-values
-       (lambda () (accept-connection *passive-socket*))
+       (lambda () (accept-connection (session-passive-socket)))
        (lambda (socket socket-address)
-	 (set! *data-socket* socket))))
+	 (set-session-data-socket socket))))
 
   (register-reply! 150 "Opening data connection.")
   (write-replies)
 
-  (set-socket-option *data-socket* level/socket
+  (set-socket-option (session-data-socket) level/socket
 		     socket/send-buffer *window-size*)
-  (set-socket-option *data-socket* level/socket
+  (set-socket-option (session-data-socket) level/socket
 		     socket/receive-buffer *window-size*))
 
 (define (maybe-close-data-connection)
-  (if (or *data-socket* *passive-socket*)
+  (if (or (session-data-socket) (session-passive-socket))
       (close-data-connection)))
 
 (define (close-data-connection)
-  (if *data-socket*
+  (if (session-data-socket)
-      (close-socket *data-socket*))
+      (close-socket (session-data-socket)))
-  (if *passive-socket*
+  (if (session-passive-socket)
-      (close-socket *passive-socket*))
+      (close-socket (session-passive-socket)))
   (register-reply! 226 "Closing data connection.")
-  (set! *data-socket* #f)
+  (set-session-data-socket #f)
-  (set! *passive-socket* #f))
+  (set-session-passive-socket #f))
 
 (define *command-alist*
   (list
@@ -645,7 +694,7 @@
   (if (eof-object? line) ; Netscape does this
       (values "QUIT" "")
       (let* ((line (trim-spaces line))
-	     (split-position (index line #\space)))
+	     (split-position (string-index line #\space)))
 	(if split-position
 	    (values (upcase-string (substring line 0 split-position))
 		    (trim-spaces (substring line
@@ -691,41 +740,39 @@
 ; printed via WRITE-REPLIES.  For the nature of the replies, see RFC
 ; 959.
 
-(define *reverse-replies* '())
-(define *reply-code* #f) ; the last one wins
 
 (define (write-replies)
-  (if (not (null? *reverse-replies*))
+  (if (not (null? (session-reverse-replies)))
-      (let loop ((messages (reverse *reverse-replies*)))
+      (let loop ((messages (reverse (session-reverse-replies))))
 	(if (null? (cdr messages))
 	    (write-final-reply (car messages))
 	    (begin
 	      (write-nonfinal-reply (car messages))
 	      (loop (cdr messages))))))
-  (set! *reverse-replies* '()))
+  (set-session-reverse-replies '()))
 
 (define (write-final-reply line)
-  (format *control-output-port* "~D ~A" *reply-code* line)
+  (format (session-control-output-port) "~D ~A" (session-reply-code) line)
-  ;; (format #t "Reply: ~D ~A~%" *reply-code* line)
+  ;; (format #t "Reply: ~D ~A~%" (session-reply-code) line)
-  (write-crlf *control-output-port*))
+  (write-crlf (session-control-output-port)))
 
 (define (write-nonfinal-reply line)
-  (format *control-output-port* "~D-~A" *reply-code* line)
+  (format (session-control-output-port) "~D-~A" (session-reply-code) line)
-  ;; (format #t "Reply: ~D-~A~%" *reply-code* line)
+  ;; (format #t "Reply: ~D-~A~%" (session-reply-code) line)
-  (write-crlf *control-output-port*))
+  (write-crlf (session-control-output-port)))
 
 (define (signal-error! code message)
   (register-reply! code message)
   (signal 'ftpd-error))
 
 (define (register-reply! code message)
-  (set! *reverse-replies* 
+  (set-session-reverse-replies
-	(cons message *reverse-replies*))
+	(cons message (session-reverse-replies)))
-  (set! *reply-code* code))
+  (set-session-reply-code code))
 
 ; Version
 
-(define *ftpd-version* "$Revision: 1.1 $")
+(define *ftpd-version* "$Revision: 1.2 $")
 
 (define (copy-port->port-binary input-port output-port)
   (let ((buffer (make-string *window-size*)))
@@ -755,7 +802,10 @@
 
 (define (copy-ascii-port->port input-port output-port)
   (let loop ()
-    (let* ((line (read-crlf-line input-port))
+    (let* ((line (read-crlf-line input-port
+				 #f
+				 90000    ; timeout
+				 500))    ; max interval
 	   (length (string-length line)))
       (if (not (eof-object? line))
 	  (begin

htmlout.scm

@@ -120,6 +120,7 @@
   (apply emit-tag out tag attrs)
   (call-with-values thunk
     (lambda results
+      (newline out)
       (emit-close-tag out tag)
       (apply values results))))
 

httpd-core.scm

@@ -50,11 +50,13 @@
 
 
 (define *http-log?* #t)
-(define *http-log-port* (error-output-port))
+(define *http-log-port* (open-output-file "/tmp/bla"))
 (define (http-log fmt . args)
-  (? (*http-log?*
+  (if *http-log?*
+      (begin 
 	(apply format *http-log-port* fmt args)
-      (force-output *http-log-port*))))
+	(force-output *http-log-port*)
+	)))
 
 
 ;;; (httpd path-handler [port server-root-dir])
@@ -74,21 +76,18 @@
 	;; closes the connection, we won't lose when we try to close the
 	;; socket by trying to flush the output buffer.
         (lambda (sock addr) ; Called once for every connection.
-	  (set-port-buffering (socket:outport sock) bufpol/none) ; No buffering
+	  (set-port-buffering (socket:outport sock) 'bufpol/none) ; No buffering
-
-	  (fork (lambda ()	; Kill this line to bag forking.
-		  (let* ((i (dup->inport  (socket:inport  sock) 0))
-			 (o (dup->outport (socket:outport sock) 1)))
-		    (set-port-buffering i bufpol/none) ; Should propagate. ecch.
-		    (with-current-input-port i		    ; bind the
-		      (with-current-output-port o	    ; stdio ports, &
-			(process-toplevel-request path-handler sock))) ; do it.
-		    (close-input-port i)	; Really only necessary
-		    (close-output-port o))))	; for non-forking variant.
-
-	  (reap-zombies) 	; Clean up: reap dead children,
-	  (close-socket sock))	;     and close socket.
 
+	 (spawn (lambda ()	; Kill this line to bag forking.
+					; Should propagate. ecch.
+		  (with-current-input-port 
+		   (socket:inport  sock)		    ; bind the
+		   (with-current-output-port 
+		    (socket:outport sock)	    ; stdio ports, &
+		    (set-port-buffering (current-input-port) 'bufpol/none)
+		    (process-toplevel-request path-handler sock)
+		    (close-socket sock))) ; do it.
+		  )))
 	port))))
 
 ;;; Top-level http request processor
@@ -141,6 +140,15 @@
   headers		; An rfc822 header alist (see rfc822.scm).
   socket)		; The socket connected to the client.
 
+(define-record-discloser type/request
+  (lambda (req)
+    (list 'request 
+	  (request:method req)
+	  (request:uri req)
+	  (request:url req)
+	  (request:version req)
+	  (request:headers req)
+	  (request:socket req))))
 ;;; A http protocol version is an integer  pair: (major . minor).
 
 (define (version< v1 v2)
@@ -249,9 +257,9 @@
 
 (define (string->words s)
   (let recur ((start 0))
-    (? ((char-set-index s non-whitespace start) =>
+    (cond ((char-set-index s non-whitespace start) =>
         (lambda (start)
-	  (? ((char-set-index s char-set:whitespace start) => 
+	  (cond ((char-set-index s char-set:whitespace start) => 
 	      (lambda (end)
 		(cons (substring s start end)
 		      (recur end))))
@@ -351,6 +359,8 @@
 		   (apply really-send-http-error-reply reply-code req args))))
 
 (define (really-send-http-error-reply reply-code req . args)
+  (http-log "sending error-reply ~a ~%" reply-code)
+
   (let* ((message (if (pair? args) (car args)))
 	 (extras  (if (pair? args) (cdr args) '()))
 
@@ -367,7 +377,7 @@
 				      (reply-code->text reply-code)
 				      new-protocol?)))
 
-	 (do-msg (lambda () (? (message (display message out) (newline out))))))
+	 (do-msg (lambda () (cond (message (display message out) (newline out))))))
 
     (if new-protocol? (begin-http-header out reply-code))
 
@@ -423,7 +433,7 @@
 	 (if message (format out "<P>~%~a~%" message))))
 
       ((http-reply/internal-error)
-       (format (error-output-port) "ERROR: ~A~%" message)
+       (format (current-error-port) "ERROR: ~A~%" message)
        (when html-ok? 
          (generic-title)
 	 (format out "The server encountered an internal error or
@@ -444,10 +454,12 @@ the requested method (~A).~%"
 
       (else (if html-ok? (generic-title))))
 
-    (? (html-ok?
+    (cond (html-ok?
 	;; Output extra stuff and close the <body> tag.
 	(for-each (lambda (x) (format out "<BR>~s~%" x)) extras)
 	(write-string "</BODY>\n" out)))
+    ; (force-output out)  ;;; TODO check this
+   ; (flush-all-ports)
     (force-output out)
 ;   (if bkp? (breakpoint "http error"))
     ))

httpd-handlers.scm

@@ -55,7 +55,7 @@
 
 (define (alist-path-dispatcher handler-alist default-handler)
   (lambda (path req)
-    (? ((and (pair? path) (assoc (car path) handler-alist)) =>
+    (cond ((and (pair? path) (assoc (car path) handler-alist)) =>
         (lambda (entry) ((cdr entry) (cdr path) req)))
        (else (default-handler path req)))))
 
@@ -175,7 +175,7 @@
       (http-error http-reply/bad-request req
 		  "Indexed search not provided for this URL.")
 
-      (? ((dotdot-check root file-path) =>
+      (cond ((dotdot-check root file-path) =>
 	     (lambda (fname) (file-serve fname file-path req)))
 	    (else
 	     (http-error http-reply/bad-request req
@@ -309,14 +309,14 @@
 	  => (lambda (open-match)
 	       (cond
 		((regexp-exec title-close-tag-regexp stuff
-			      (match:end open-match))
+			      (match:end open-match 0))
 		 => (lambda (close-match)
 		      (string-cut (substring stuff
-					     (match:end open-match)
+					     (match:end open-match 0)
-					     (match:start close-match))
+					     (match:start close-match 0))
 				  n)))
 		(else (string-cut (substring stuff
-					     (match:end open-match)
+					     (match:end open-match 0)
 					     (string-length stuff))
 				  n)))))
 	 (else ""))))))

modules.scm

@@ -34,11 +34,13 @@
 
 
 (define-structure crlf-io (export read-crlf-line
+				  read-crlf-line-timeout
 				  write-crlf)
   (open ascii		; ascii->char
 	scsh		; read-line write-string force-output
 	receiving	; MV return (RECEIVE and VALUES)
 	let-opt		; let-optionals
+	threads         ; sleep
 	scheme)	
   (files crlf-io))
 
@@ -64,6 +66,7 @@
   (open receiving	; MV return (RECEIVE and VALUES)
 	condhax		; ? for COND
 	scsh-utilities	; index
+	string-lib
 	let-opt         ; let-optionals
 	strings		; lowercase-string uppercase-string
 	crlf-io		; read-crlf-line
@@ -96,6 +99,7 @@
 				      uri-path-list->path
 				      simplify-uri-path)
   (open scsh-utilities
+	string-lib
 	let-opt
 	receiving
 	condhax
@@ -142,6 +146,7 @@
   (open defrec-package
 	receiving
 	condhax
+	string-lib
 	char-set-package
 	uri-package
 	scsh-utilities
@@ -227,7 +232,8 @@
 
 				     set-my-fqdn!
 				     set-my-port!)
-  (open scsh
+  (open threads
+	scsh
 	receiving
 	let-opt
 	crlf-io
@@ -237,6 +243,7 @@
 	strings
 	char-set-package
 	defrec-package
+	define-record-types
 	handle
 	conditions	; condition-stuff
 	defenum-package
@@ -251,7 +258,7 @@
 
 ;;; For parsing submissions from HTML forms.
 (define-structure parse-html-forms (export parse-html-form-query unescape-uri+)
-  (open scsh scsh-utilities let-opt
+  (open scsh scsh-utilities let-opt string-lib
 	receiving uri-package strings condhax scheme)
   (files parse-forms))
 
@@ -270,6 +277,7 @@
 					     cgi-handler
 					     initialise-request-invariant-cgi-env)
   (open strings
+	string-lib
 	rfc822
 	crlf-io			; WRITE-CRLF
 	uri-package
@@ -325,7 +333,6 @@
 	htmlout-package
 	conditions	; CONDITION-STUFF
 	url-package	; HTTP-URL record type
-	handle-fatal-error
 	scheme)
   (files httpd-handlers))
 
@@ -365,6 +372,7 @@
 				       find-info-file
 				       info-gateway-error)
   (open big-scheme
+	string-lib
 	conditions signals handle
 	switch-syntax
 	condhax
@@ -374,7 +382,6 @@
 	httpd-error
 	url-package
 	uri-package
-	handle-fatal-error
 	scsh
 	scheme)
   (files info-gateway))
@@ -416,6 +423,10 @@
 	structure-refs
 	handle-fatal-error
 	scsh
+	threads
+	fluids
+	string-lib
+	defrec-package
 	crlf-io strings ls)
   (access big-scheme)
   (files ftpd))

parse-forms.scm

@@ -4,7 +4,7 @@
 ;;; See http://www.w3.org/hypertext/WWW/MarkUp/html-spec/html-spec_toc.html
 
 ;;; Imports and non-R4RS'isms
-;;;	index			(scsh)
+;;;	string-index		(string srfi)
 ;;;	let-optionals		(let-opt package)
 ;;;	receive			(Multiple-value return)
 ;;;     unescape-uri
@@ -45,9 +45,11 @@
 (define (parse-html-form-query q)
   (let ((qlen (string-length q)))
     (let recur ((i 0))
-      (? ((index q #\= i) =>
+      (cond 
+       ((>= i qlen) '())
+       ((string-index q #\= i) =>
 	(lambda (j)
-	    (let ((k (or (index q #\& j) qlen)))
+	  (let ((k (or (string-index q #\& j) qlen)))
 	    (cons (cons (unescape-uri+ q i j)
 			(unescape-uri+ q (+ j 1) k))
 		  (recur (+ k 1))))))

rfc822.scm

@@ -105,7 +105,7 @@
 
 	(values #f #f)	; Blank line or EOF terminates header text.
 
-	(? ((index line1 #\:) =>	; Find the colon and
+	(? ((string-index line1 #\:) =>	; Find the colon and
 	    (lambda (colon)		; split out field name.
 	      (let ((name (string->symbol-pref (substring line1 0 colon))))
 		;; Read in continuation lines.

uri.scm

@@ -50,7 +50,11 @@
 ;;; Returns four values: scheme, path, search, frag-id.
 ;;; Each value is either #f or a string.
 
-(define uri-reserved (string->char-set "=;/#?: "))
+
+;;; MG: I think including = here will break up things, since it may be
+;;; part of the search string, preventing the ? to be found (+ and &
+;;; are excluded anyway).
+(define uri-reserved (string->char-set ";/#?: "))
 
 (define (parse-uri s)
   (let* ((slen (string-length s))
@@ -68,7 +72,6 @@
 	 (ques (and rs-penult (char=? (string-ref s rs-penult) #\?) rs-penult))
 
 	 (path-end (or ques sharp slen)))
-
     (values (and colon (substring s 0 colon))
 	    (split-uri-path s path-start path-end)
 	    (and ques (substring s (+ ques 1) (or sharp slen)))
@@ -231,7 +234,7 @@
 (define (split-uri-path uri start end)		; Split at /'s (infix grammar).
   (let split ((i start))			; "" -> ("")
     (? ((>= i end) '(""))
-       ((index uri #\/ i) =>
+       ((string-index uri #\/ i) =>
 	(lambda (slash)
 	  (cons (substring uri i slash)
 		(split (+ slash 1)))))