diff --git a/scheme/httpd/core.scm b/scheme/httpd/core.scm index 03b8643..96ede84 100644 --- a/scheme/httpd/core.scm +++ b/scheme/httpd/core.scm @@ -269,8 +269,10 @@ ;; Interpolate the userhost struct from our net connection. (if (and (pair? path) (string=? (car path) "")) (let* ((addr (socket-local-address socket)) - (local-name (my-reported-fqdn addr options)) - (portnum (my-reported-port addr options))) + (local-name (or (httpd-options-fqdn options) + (socket-address->fqdn addr #t))) + (portnum (or (httpd-options-reported-port options) + (my-reported-port addr)))) (make-http-url (make-userhost #f #f local-name (number->string portnum)) @@ -353,46 +355,7 @@ (write-crlf port)) headers)) -;;; Return my Internet host name (my fully-qualified domain name). -;;; This works only if an actual resolver is behind host-info. -;;; -;;; In case of aliased names, you just might get the wrong one. -;;; Furthermore, you may get screwed in the presence of a server -;;; accelerator such as Squid. - - -(define my-reported-fqdn - (let ((fqdn-lock (make-lock)) - (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 - (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) - (or (httpd-options-reported-port options) - (receive (ip-addr portnum) (socket-address->internet-address addr) - portnum))) +(define (my-reported-port addr) + (receive (ip-addr portnum) (socket-address->internet-address addr) + portnum)) diff --git a/scheme/lib/dns.scm b/scheme/lib/dns.scm index d4f84bc..ed55249 100644 --- a/scheme/lib/dns.scm +++ b/scheme/lib/dns.scm @@ -1333,3 +1333,28 @@ (d 5 "data " (rr-data-wks:data dns-msg))) ))) + +(define *fqdn-lock* (make-lock)) +(define *fqdn-cache* '()) + +(define (socket-address->fqdn addr cache?) + (receive (ip32 port) + (socket-address->internet-address addr) + (internet-address->fqdn ip32 cache?))) + +(define (internet-address->fqdn ip32 cache?) + (if cache? + (begin + (obtain-lock *fqdn-lock*) + (cond + ((assv ip32 *fqdn-cache*) => + (lambda (pair) + (release-lock *fqdn-lock*) + (cdr pair))) + (else + (release-lock *fqdn-lock*) + (let ((fqdn (dns-lookup-ip ip32))) + (set! *fqdn-cache* + (cons (cons ip32 fqdn) *fqdn-cache*)) + fqdn)))) + (dns-lookup-ip ip32))) diff --git a/scheme/packages.scm b/scheme/packages.scm index 7fcda8f..37d88f3 100644 --- a/scheme/packages.scm +++ b/scheme/packages.scm @@ -184,20 +184,22 @@ net:daytime)) (define-interface dns-interface - (export dns-clear-cache ; clears the cache - dns-lookup ; complex lookup function - dns-lookup-name ; simple lookup function - dns-inverse-lookup ; obsolete, use dns-lookup-ip - dns-lookup-ip ; simple lookup function - dns-lookup-nameserver ; simple lookup function - dns-lookup-mail-exchanger ; simple lookpu function - show-dns-message ; prints a human readable dns-msg - force-ip ; reruns a lookup until a ip is resolved - force-ip-list ; reruns a lookup until a list of ips is resolved - address32->ip-string ; converts a address32 in an ip-string - ip-string->address32 ; converts a ip-string in an address32 - dns-find-nameserver ; returns a nameserver - dns-find-nameserver-list)) ; returns a list of nameservers + (export dns-clear-cache ; clears the cache + dns-lookup ; complex lookup function + dns-lookup-name ; simple lookup function + dns-inverse-lookup ; obsolete, use dns-lookup-ip + dns-lookup-ip ; simple lookup function + dns-lookup-nameserver ; simple lookup function + dns-lookup-mail-exchanger ; simple lookpu function + show-dns-message ; prints a human readable dns-msg + force-ip ; reruns a lookup until a ip is resolved + force-ip-list ; reruns a lookup until a list of ips is resolved + address32->ip-string ; converts a address32 in an ip-string + ip-string->address32 ; converts a ip-string in an address32 + dns-find-nameserver ; returns a nameserver + dns-find-nameserver-list ; returns a list of nameservers + socket-address->fqdn + internet-address->fqdn)) (define-interface cgi-script-interface (export cgi-form-query))