Use DNS for FQDN determination in SMTP.
This commit is contained in:
parent
1cfa3e3595
commit
cfc8d84aad
|
@ -1358,3 +1358,16 @@
|
||||||
(cons (cons ip32 fqdn) *fqdn-cache*))
|
(cons (cons ip32 fqdn) *fqdn-cache*))
|
||||||
fqdn))))
|
fqdn))))
|
||||||
(dns-lookup-ip ip32)))
|
(dns-lookup-ip ip32)))
|
||||||
|
|
||||||
|
(define (host-fqdn name-or-socket-address)
|
||||||
|
(if (socket-address? name-or-socket-address)
|
||||||
|
(socket-address->fqdn name-or-socket-address #f)
|
||||||
|
(internet-address->fqdn
|
||||||
|
(car
|
||||||
|
(host-info:addresses
|
||||||
|
(host-info name-or-socket-address)))
|
||||||
|
#f)))
|
||||||
|
|
||||||
|
(define (system-fqdn)
|
||||||
|
(internet-address->fqdn (car (host-info:addresses (host-info (system-name))))
|
||||||
|
#t))
|
||||||
|
|
|
@ -29,11 +29,6 @@
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
|
||||||
;;; This is broken -- the (SYSTEM-NAME) proc returns a local name, not
|
|
||||||
;;; a useful Internet host name. How do we do that?
|
|
||||||
;;; [Andreas:] I've inserted a way to do this. It works fine on my
|
|
||||||
;;; system. Does it work on your, too?
|
|
||||||
|
|
||||||
;;; (send-mail-via-smtp from to-list headers body [host])
|
;;; (send-mail-via-smtp from to-list headers body [host])
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;;; Mail message to recipients in list TO-LIST. Message handed off to server
|
;;; Mail message to recipients in list TO-LIST. Message handed off to server
|
||||||
|
@ -50,8 +45,11 @@
|
||||||
(define (send-mail-via-smtp from to-list headers body . maybe-host)
|
(define (send-mail-via-smtp from to-list headers body . maybe-host)
|
||||||
(call-with-current-continuation
|
(call-with-current-continuation
|
||||||
(lambda (bailout)
|
(lambda (bailout)
|
||||||
(let ((local (host-info:name (host-info (system-name))))
|
(let* ((host (:optional maybe-host "localhost"))
|
||||||
(socket (smtp/open (:optional maybe-host "localhost"))))
|
(local (if (string=? host "localhost")
|
||||||
|
(system-name) ; we don't need any DNS for that
|
||||||
|
(system-fqdn)))
|
||||||
|
(socket (smtp/open host)))
|
||||||
(receive (code text)
|
(receive (code text)
|
||||||
(smtp-transactions/no-close socket ; Do prologue.
|
(smtp-transactions/no-close socket ; Do prologue.
|
||||||
(smtp/helo local)
|
(smtp/helo local)
|
||||||
|
|
|
@ -199,7 +199,9 @@
|
||||||
dns-find-nameserver ; returns a nameserver
|
dns-find-nameserver ; returns a nameserver
|
||||||
dns-find-nameserver-list ; returns a list of nameservers
|
dns-find-nameserver-list ; returns a list of nameservers
|
||||||
socket-address->fqdn
|
socket-address->fqdn
|
||||||
internet-address->fqdn))
|
internet-address->fqdn
|
||||||
|
host-fqdn
|
||||||
|
system-fqdn))
|
||||||
|
|
||||||
(define-interface cgi-script-interface
|
(define-interface cgi-script-interface
|
||||||
(export cgi-form-query))
|
(export cgi-form-query))
|
||||||
|
@ -433,13 +435,14 @@
|
||||||
|
|
||||||
(define-structure smtp smtp-interface
|
(define-structure smtp smtp-interface
|
||||||
|
|
||||||
(open scsh ; write-string read-string/partial force-output
|
(open scsh ; write-string read-string/partial force-output
|
||||||
; system-name user-login-name and sockets
|
; user-login-name and sockets
|
||||||
(subset srfi-1 (filter-map))
|
(subset srfi-1 (filter-map))
|
||||||
crlf-io ; read-crlf-line write-crlf
|
crlf-io ; read-crlf-line write-crlf
|
||||||
receiving ; values receive
|
receiving ; values receive
|
||||||
let-opt ; let-optionals
|
let-opt ; let-optionals
|
||||||
error-package ; error
|
error-package ; error
|
||||||
|
dns ; SYSTEM-FQDN
|
||||||
scheme)
|
scheme)
|
||||||
(files (lib smtp)))
|
(files (lib smtp)))
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue