make MY-REPORTED-FQDN fit for lots of virtual hosts
This commit is contained in:
parent
27f6bb4dbd
commit
0ab5c48cfc
|
@ -345,25 +345,32 @@
|
|||
|
||||
(define my-reported-fqdn
|
||||
(let ((fqdn-lock (make-lock))
|
||||
(fqdn-cache #f)
|
||||
(used-addr #f)
|
||||
(used-options #f))
|
||||
(fqdn-cache '()) ; listof (ip32 port options . fqdn)
|
||||
(key-ip32 car)
|
||||
(key-port cadr)
|
||||
(key-options caddr))
|
||||
(lambda (addr options)
|
||||
(obtain-lock fqdn-lock)
|
||||
(let ((result
|
||||
(if fqdn-cache
|
||||
(or (and (equal? used-addr addr)
|
||||
(equal? used-options options))
|
||||
fqdn-cache)
|
||||
(begin
|
||||
(set! fqdn-cache (or (httpd-options-fqdn options)
|
||||
(dns-lookup-ip (socket-address->string addr #f))
|
||||
(host-info:name (host-info addr))))
|
||||
(set! used-addr addr)
|
||||
(set! used-options options)
|
||||
fqdn-cache))))
|
||||
(let
|
||||
((result
|
||||
(receive (ip32 port)
|
||||
(socket-address->internet-address addr)
|
||||
(let ((fqdn-entry
|
||||
(find (lambda (entry)
|
||||
(let ((entry-key (car entry)))
|
||||
(and (= ip32 (key-ip32 entry-key))
|
||||
(= port (key-port entry-key))
|
||||
(eq? options (key-options entry-key)))))
|
||||
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)
|
||||
|
||||
result))))
|
||||
|
||||
(define (my-reported-port addr options)
|
||||
|
|
|
@ -38,7 +38,11 @@
|
|||
smtp-transactions/no-close
|
||||
smtp/open smtp/helo smtp/mail smtp/rcpt smtp/data
|
||||
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
|
||||
(export read-rfc822-headers
|
||||
|
@ -695,7 +699,8 @@
|
|||
httpd-responses
|
||||
|
||||
sunet-version
|
||||
scheme)
|
||||
scheme
|
||||
srfi-1) ; find
|
||||
(files (httpd core)))
|
||||
|
||||
(define-structures ((httpd-make-options httpd-make-options-interface)
|
||||
|
|
Loading…
Reference in New Issue