diff --git a/cgi-server.scm b/cgi-server.scm index a107216..12bf638 100644 --- a/cgi-server.scm +++ b/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 diff --git a/ftpd.scm b/ftpd.scm index e628c41..5060d9f 100644 --- a/ftpd.scm +++ b/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*))) diff --git a/httpd-core.scm b/httpd-core.scm index d75a608..d71f5b7 100644 --- a/httpd-core.scm +++ b/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 - (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. - ))) + (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 @@ -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) diff --git a/modules.scm b/modules.scm index 51c5283..44f864d 100644 --- a/modules.scm +++ b/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 diff --git a/sunet-utilities.scm b/sunet-utilities.scm index b57f139..ee2a1cd 100644 --- a/sunet-utilities.scm +++ b/sunet-utilities.scm @@ -1,7 +1,11 @@ ; some useful utilities -(define (host-name-or-empty addr) - (with-fatal-error-handler - (lambda (condition more) - "") - (host-info:name (host-info addr)))) \ No newline at end of file +(define (host-name-or-ip addr) + (with-fatal-error-handler + (lambda (condition more) + (call-with-values + (lambda () (socket-address->internet-address addr)) + (lambda (ip port) + (format-internet-host-address ip)))) + (host-info:name (host-info addr)))) +