scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

make MY-REPORTED-FQDN fit for lots of virtual hosts

This commit is contained in:
interp 2002-09-02 14:34:31 +00:00
parent 27f6bb4dbd
commit 0ab5c48cfc
2 changed files with 30 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
scheme/httpd/core.scm
View File

@ -345,25 +345,32 @@
(define my-reported-fqdn (define my-reported-fqdn
(let ((fqdn-lock (make-lock)) (let ((fqdn-lock (make-lock))
(fqdn-cache #f) (fqdn-cache '()) ; listof (ip32 port options . fqdn)
(used-addr #f) (key-ip32 car)
(used-options #f)) (key-port cadr)
(key-options caddr))
(lambda (addr options) (lambda (addr options)
(obtain-lock fqdn-lock) (obtain-lock fqdn-lock)
(let ((result (let
(if fqdn-cache ((result
(or (and (equal? used-addr addr) (receive (ip32 port)
(equal? used-options options)) (socket-address->internet-address addr)
fqdn-cache) (let ((fqdn-entry
(begin (find (lambda (entry)
(set! fqdn-cache (or (httpd-options-fqdn options) (let ((entry-key (car entry)))
(dns-lookup-ip (socket-address->string addr #f)) (and (= ip32 (key-ip32 entry-key))
(host-info:name (host-info addr)))) (= port (key-port entry-key))
(set! used-addr addr) (eq? options (key-options entry-key)))))
(set! used-options options) fqdn-cache)))
fqdn-cache)))) (if fqdn-entry
(cdr fqdn-entry)
(let ((fqdn (or (httpd-options-fqdn options)
(dns-lookup-ip ip32)
(host-info:name (host-info addr)))))
(set! fqdn-cache
(cons (cons (list ip32 port options) fqdn) fqdn-cache))
fqdn))))))
(release-lock fqdn-lock) (release-lock fqdn-lock)
result)))) result))))
(define (my-reported-port addr options) (define (my-reported-port addr options)

9
scheme/packages.scm
View File

@ -38,7 +38,11 @@
smtp-transactions/no-close smtp-transactions/no-close
smtp/open smtp/helo smtp/mail smtp/rcpt smtp/data smtp/open smtp/helo smtp/mail smtp/rcpt smtp/data
smtp/send smtp/soml smtp/saml smtp/rset smtp/expn smtp/send smtp/soml smtp/saml smtp/rset smtp/expn
smtp/help smtp/noop smtp/quit smtp/turn)) smtp/help smtp/noop smtp/quit smtp/turn
handle-smtp-reply
read-smtp-reply
parse-smtp-reply
smtp-stuff))
(define-interface rfc822-interface (define-interface rfc822-interface
(export read-rfc822-headers (export read-rfc822-headers
@ -695,7 +699,8 @@
httpd-responses httpd-responses
sunet-version sunet-version
scheme) scheme
srfi-1) ; find
(files (httpd core))) (files (httpd core)))
(define-structures ((httpd-make-options httpd-make-options-interface) (define-structures ((httpd-make-options httpd-make-options-interface)