+ Use fork-thread

+ Replaced host-name-or-empty by host-name-of-ip

cgi-server.scm

@@ -188,7 +188,7 @@
 	  ("PATH_TRANSLATED" . ,path-translated)
 	  ("SCRIPT_NAME"     . ,script-name)
 
-	  ("REMOTE_HOST"  . ,(host-name-or-empty raddr))
+	  ("REMOTE_HOST"  . ,(host-name-or-ip raddr))
 	  ("REMOTE_ADDR"  . ,(format-internet-host-address rhost))
 
 	  ;; ("AUTH_TYPE" . xx)			; Random authentication

ftpd.scm

@@ -140,7 +140,7 @@
 	(lambda (socket address)
 	  (let ((remote-address (socket-address->string address)))
 	    (set-ftp-socket-options! socket)
-	    (spawn
+	    (fork-thread
 	     (spawn-to-handle-connection socket
 					 address
 					 anonymous-home
@@ -1127,7 +1127,7 @@
 
 ; Version
 
-(define *ftpd-version* "$Revision: 1.26 $")
+(define *ftpd-version* "$Revision: 1.27 $")
 
 (define (copy-port->port-binary input-port output-port)
   (let ((buffer (make-string *window-size*)))

httpd-core.scm

@@ -50,7 +50,7 @@
 
 
 (define *http-log?* #t)
-(define *http-log-port* (open-output-file "/tmp/bla"))
+(define *http-log-port* (current-error-port))
 (define (http-log fmt . args)
   (if *http-log?*
       (begin 
@@ -77,16 +77,17 @@
 	;; 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
-	  (spawn (lambda ()	; Kill this line to bag forking.
+	  (fork-thread 
+	   (lambda ()	
 					; Should propagate. ecch.
-		   (with-current-input-port 
+	     (with-current-input-port 
-		    (socket:inport  sock)		    ; bind the
+	      (socket:inport  sock)		    ; bind the
-		    (with-current-output-port 
+	      (with-current-output-port 
-		     (socket:outport sock)	    ; stdio ports, &
+	       (socket:outport sock)	    ; stdio ports, &
-		     (set-port-buffering (current-input-port) bufpol/none)
+	       (set-port-buffering (current-input-port) bufpol/none)
-		     (process-toplevel-request path-handler sock)
+	       (process-toplevel-request path-handler sock)
-		     (close-socket sock))) ; do it.
+	       (close-socket sock))) ; do it.
-		   )))
+	     )))
 	port))))
 
 ;;; Top-level http request processor
@@ -182,7 +183,7 @@
     ;; Blat out some logging info.
      (if *http-log?*
 	 (let* ((addr (socket-remote-address sock))
-		(host (host-name-or-empty addr)))
+		(host (host-name-or-ip addr)))
 	   (http-log "~a: ~a~%" host line)))
 
     (if (eof-object? line)

modules.scm

@@ -12,11 +12,12 @@
   (files format-net))
 	
 (define-interface sunet-utilities-interface
-  (export host-name-or-empty))
+  (export host-name-or-ip))
 
 (define-structure sunet-utilities sunet-utilities-interface
   (open scsh
 	scheme
+	format-net
 	handle-fatal-error)
   (files sunet-utilities))
 
@@ -272,6 +273,7 @@
 
 (define-structure httpd-core httpd-core-interface
   (open threads
+	thread-fluids               ; fork-thread
 	scsh
 	receiving
 	let-opt
@@ -498,6 +500,7 @@
 	handle-fatal-error
 	scsh
 	threads threads-internal    ; last one to get CURRENT-THREAD
+	thread-fluids               ; fork-thread
 	fluids
 	string-lib
 	big-util

sunet-utilities.scm

@@ -1,7 +1,11 @@
 ; some useful utilities
 
-(define (host-name-or-empty addr)
+(define (host-name-or-ip addr)
-      (with-fatal-error-handler
+  (with-fatal-error-handler
-       (lambda (condition more)
+   (lambda (condition more)
-	 "")
+     (call-with-values
-       (host-info:name (host-info addr))))
+      (lambda () (socket-address->internet-address addr))
+      (lambda (ip port)
+	(format-internet-host-address ip))))
+   (host-info:name (host-info addr))))
+