LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031583. :SYSTEM-TYPE :LOGICAL :VERSION 8. :TYPE "LISP" :NAME "CLIENT" :DIRECTORY ("REL3-SOURCE" "MAIL-DAEMON") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758715791. :AUTHOR "REL3" :LENGTH-IN-BYTES 21429. :LENGTH-IN-BLOCKS 21. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          ;;;-*- Mode:Common-Lisp; Package:MAIL; Base:10 -*-;;;                           RESTRICTED RIGHTS LEGEND;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in;;;Technical Data and Computer Software clause at 52.227-7013.;;;                     TEXAS INSTRUMENTS INCORPORATED.;;;                              P.O. BOX 2909;;;                           AUSTIN, TEXAS 78769;;;                                 MS 2151;;; Copyright (C) 1985,1987 Texas Instruments Incorporated. All rights reserved.(defmethod (NET:HOST :MAIL-HOST-P) ()  (net:assure-host-parsed)  (assoc :mail-to-user (send self :sorted-service-list)))(defmethod (NET:HOST :MAIL-TO-USER) (operation host-queue)    (log-debug :delivery "Attempting delivery to ~S" self)  (block :mail-to-user    (net:assure-host-parsed)    (when (eq self si:local-host)      (return-from :mail-to-user (host-queue-direct-delivery host-queue)))        (condition-call-if (not *debug-mailer*) (condition)(let ((first-service-element (member :mail-to-user (send self :sorted-service-list) :key #'first)))  (unless first-service-element    ;;(ferror 'host:gni-service-error "No MAIL-TO-USER service defined for host ~A" self)    (mailer-error :delivery "No MAIL-TO-USER service defined for host ~A" self)    (return-from :mail-to-user nil))  (do* ((service-element-list first-service-element      (member :mail-to-user (rest service-element-list) :key #'first)))       ((null service-element-list))        (let* ((service-element (first service-element-list))   (next-service-element (assoc :mail-to-user (rest service-element-list) :test #'eq))   (medium (net:find-medium (second service-element) nil))   (service-implementation (net:find-service-implementation (third service-element))))            (when (and medium service-implementation (send medium :connection-possible-p self) (send service-implementation :operation-handled-p operation))(let (result)  (condition-call-if (not *debug-mailer*) (condition)      (setq result    (send service-implementation operation host-queue self nil medium))    ((handle-condition-p condition)     (setq result condition)))  (if (not (errorp result))      (return-from :mail-to-user result)    (when (or (null next-service-element)      (and *interactive-delivery-in-progress*   (not net:*try-all-service-implementations*))      (not *try-all-mail-services*))      (return-from :mail-to-user result))))))))      ((handle-condition-p condition)       (unless (ignored-network-condition-p condition) (mailer-error :delivery "Error during MAIL-TO-USER service while sending to host ~A:  ~A"       self (send condition :report-string)))       condition))))(defsignal CHAOS-MAIL-CLIENT-ERROR (error sys:network-error mailer-error chaos-mail-client-error) ()  "Unexpected problem in chaos mail client protocol.")(defmethod (CHAOS-MAIL-SERVICE :DELIVER) (host-queue host &optional error-p (medium :byte-stream) (contact-name "MAIL"))    (log-debug :chaos-mail-client "Attempting MAIL connection to ~A" host)  (unless (host:superior-medium-p medium :byte-stream)    (ferror 'host:gni-service-error "Service ~a cannot connect using ~a medium" self medium))    (loop    with max = (length (host-queue-message-alist host-queue))    with result    when (minusp (decf max)) return nil;avoid getting stuck here in case of a mail loop (message comes right back)    for message-item in (host-queue-message-alist host-queue)    do    (with-open-stream (stream (host:open-connection-on-mediumhost medium contact-name:stream-type :character-stream:error error-p:timeout (if *interactive-delivery-in-progress*     (* 15 60)   (* 60 60))))      (cond ((errorp stream)     (log-event :chaos-mail-client "Error connecting to ~A: ~A" host stream)     (return stream))    (t     (setq result (chaos-mail-client host stream message-item host-queue))     (if (errorp result) (return result);Assume already logged       (log-debug :chaos-mail-client "MAIL session with ~A complete" host )))))))(defun CHAOS-MAIL-CLIENT (host stream message-item host-queue)    (log-event :chaos-mail-client "Connected for MAIL to ~A via ~S" host (send stream :send-if-handles :network-type))  (let* ((message (car message-item)) (address-list (cdr message-item)) delivered response state)    (condition-call-if (not *debug-mailer*) (condition)    (block do-message  (when (null address-list)    (return-from do-message))  ;; Send address list.  (dolist (address address-list)    (setq state :send-recipient)    (log-debug :chaos-mail-client "-> ~A" (send address :string-for-mail-server))    (write-line (send address :string-for-mail-server) stream)    (send stream :force-output)    (setq response (read-line-with-timeout stream nil :eof))    (setq state :read-response)    (log-debug :chaos-mail-client "<- ~A" response)    (when (or (null response) (eq response :eof) (zerop (length response)))      (ferror 'chaos-mail-client-error "Session aborted.  Received ~A from server."      (if (null response) "timeout" (if (eq response :eof) "EOF" "empty string"))))    (cond ((eql (char response 0) #\+)   (push address delivered))  (t   (setf (char response 0) #\Space)   (send message :dispose-address address :rejected host (copy-seq response))   (delete address message-item)   (log-event :chaos-mail-client "Address ~A rejected by host ~A -- ~A" address host response))))    ;; Blank line delimits end of recipients.  (terpri stream)  (send stream :force-output)  (setq state :send-text)  (log-debug :chaos-mail-client "-> [Send text]")  (if (null delivered)      ;; Don't bother sending the text if no recipients accepted      (terpri stream)    (with-open-stream (msg-stream (make-message-input-stream message nil t))      (stream-copy-until-eof msg-stream stream)))  (log-debug :chaos-mail-client "-> [Send EOF]")  (setq state :finish)  (send stream :eof)  (send stream :force-output)  (setf response (read-line-with-timeout stream nil :eof))  (when (or (null response) (eq response :eof) (zerop (length response)))    (ferror 'chaos-mail-client-error "Session aborted.  Received ~A after sending text."    (if (null response) "timeout" (if (eq response :eof) "EOF" "empty string"))))  (log-debug :chaos-mail-client "<- ~A" response)  (cond ((eql (char response 0) #\+) ;; Finished with this message (dispose-host-queue-message host message-item) (log-event :chaos-mail-client "Delivered ~A to host ~A for addresses ~{~A~^, ~}."    message host delivered))(t (log-event :chaos-mail-client "Text rejected by remote: ~A" (copy-seq response))))  (send message :update))            ;; Condition-call forms      ((handle-condition-p condition)       (setf (host-queue-last-error host-queue) condition)       (if (ignored-network-condition-p condition)   (log-event :chaos-mail-client "Error sending to host ~A: ~A" host condition) (mailer-error :chaos-mail-client "Chaos MAIL client error while sending to host ~A~%~A"       host condition))       (when (eq state :finish) (log-event :chaos-mail-client "Error was during final ack.  This may cause a duplicate?!"))       condition)      (:no-error       (declare (ignore condition))       (setf (host-queue-last-error host-queue) nil)       nil))))(defmethod (MESSAGE :DIRECT-DELIVERY) ()  ;; Assume this is used only for interactive delivery -- message is not in queue  (dolist (address address-list)    (when (send address :local-p)      (let ((result (direct-delivery self address)))(if (errorp result)    (send self :dispose-address address :direct-delivery-error nil (send result :report-string))  (send self :dispose-address address :delivered si:local-host))))))(defun HOST-QUEUE-DIRECT-DELIVERY (host-queue)    (let ((message-alist (host-queue-message-alist host-queue))result)    (dolist (message-item message-alist)      (let ((message (car message-item)))(dolist (address (cdr message-item))  (setq result (direct-delivery (car message-item) address))  (if (errorp result)      (send address :set-delivery-status :deferred si:local-host (send result :report-string))      (send message :dispose-address address :delivered si:local-host)      (delete address (the list message-item) :test #'eq)))(send message :update)))))(defun DIRECT-DELIVERY (message address)    (let* ((directory (send address :local-part-as-directory)) path)    (condition-call-if (not *debug-mailer*) (condition)(block output  (setq path (make-pathname :host si:local-host    :directory directory :name "MAIL" :type :text))  (with-open-file (msg-out path :direction :output :if-exists :append :if-does-not-exist :create)    (let ((return-path (send message :return-path)))      (when return-path(format msg-out "Return-Path: ~A~%" (send return-path :string-for-message))))    (with-open-stream (msg-in (make-message-input-stream message nil t))      (stream-copy-until-eof msg-in msg-out)      (format msg-out "~%~C~%" #\Or)))  (log-event :delivery "Address ~A delivered to file ~A." address path))      ((handle-condition-p condition)       (mailer-error :delivery "Error writing local mail for ~A into ~A:  ~A"     address path condition)       condition)      (:no-error       (declare (ignore condition))       nil))))(defsubst REPLY-CODE (string)  (and (stringp string)       (>= (length string) 3)       (parse-integer string :end 3 :junk-allowed t)));;;(defun test ();;;  (let (line code state);;;    (dotimes (x 100);;;      (get-smtp-reply *terminal-io* line code state);;;      (zwei:echo-values *terminal-io* line code state))));;; Fix for spr#4742(defmacro GET-SMTP-REPLY (stream line code state);;;Read SMTP reply STREAM into LINE setting CODE to the reply code and;;;STATE to :READ-REPLY before the read and :SEND-COMMAND after the read;;;completes. STATE, LINE, and CODE must be local variables bound by the caller.    `(loop     with (.this-line. .composite-line. .continued-p.)     do     (setf ,state :reply-wait   .this-line. (read-line-with-timeout ,stream)   ,state :send-command   ,code (and .this-line. (reply-code .this-line.)))     (log-debug :smtp-client "<- ~A" .this-line.)     (setq .continued-p. (and .this-line.      (>= (length .this-line.) 4)      (char= (char .this-line. 3) #\-)))     (cond ((and .composite-line. .this-line.)    ;;continuation of a multi-line reply    (setq .composite-line. (string-append .composite-line. #\Newline .this-line.)))   (.continued-p.    ;; First line of a multi-line reply... initialize composite    (setq .composite-line. (copy-seq .this-line.)))   (t    ;;Single line reply    (setq .composite-line. .this-line.)))     until (not .continued-p.)     finally     (setf ,line .composite-line.)     (return ,line)));;;(defmacro GET-SMTP-REPLY (stream line code state);;;;;;Read SMTP reply STREAM into LINE setting CODE to the reply code and;;;;;;STATE to :READ-REPLY before the read and :SEND-COMMAND after the read;;;;;;completes. STATE, LINE, and CODE must be local variables bound by the caller.;;;  ;;;  `(progn;;;     (setf ,state :reply-wait;;;   ,line (read-line-with-timeout ,stream);;;   ,state :send-command;;;   ,code (and ,line (reply-code ,line)));;;     (log-debug :smtp-client "<- ~A" ,line);;;     ,line));;;(defmacro SEND-SMTP-COMMAND (stream format-string &rest format-args)  `(progn     (format ,stream ,format-string ,@format-args)     (send ,stream :force-output)     (log-debug :smtp-client (string-append "-> " ,format-string) ,@format-args)     ))(defmethod (SMTP-MAIL-SERVICE :DELIVER) (host-queue host &optional error-p (medium :byte-stream) (contact-name "SMTP"))    (log-debug :smtp-client "Attempting SMTP connection to ~A" host)  ;;(unless (host:superior-medium-p medium :byte-stream)  ;;(ferror 'host:gni-service-error "Service ~a cannot connect using ~a medium" self medium))    (with-open-stream (stream (host:open-connection-on-medium host medium contact-name    :stream-type :ascii-translating-character-stream    :error error-p    :timeout (if *interactive-delivery-in-progress* (* 15 60)       (* 60 60))))    (cond ((errorp stream)   (log-event :smtp-client "Error connecting to ~A: ~A" host stream)   stream)  (t   (prog1     (smtp-mail-client host stream host-queue)     (log-debug :smtp-client "SMTP session with ~A complete" host ))))));;For Rel2 compat;;(defmethod (CHAOS-SMTP-MAIL-SERVICE :DELIVER) (host-queue host;;       &optional error-p (medium :chaos-stream) (contact-name "CHAOS-SMTP"));;  ;;  (log-debug :chaos-smtp-client "Attempting CHAOS-SMTP connection to ~A" host);;  (with-open-stream (stream (host:open-connection-on-medium host medium contact-name;;    ;; :stream-type :ascii-translating-character-stream;;    :error error-p;;    :timeout (if *interactive-delivery-in-progress*;; (* 15 60);;       (* 60 60))));;    (cond ((errorp stream);;   (log-event :chaos-smtp-client "Error connecting to ~A: ~A" host stream);;   stream);;  (t;;   (prog1;;     (smtp-mail-client host stream host-queue);;     (log-debug :chaos-smtp-client "CHAOS-SMTP session with ~A complete" host ))))))(defun SMTP-MAIL-CLIENT (host stream host-queue)    (let ((*print-base* 10)(*read-base* 10)(state :reply-wait) reply-line reply-code cleanup message address-list delivered)        (log-event :smtp-client "Connected for SMTP to ~A via ~S" host (send stream :send-if-handles :network-type))    (unwind-protect(condition-call-if (not *debug-mailer*) (condition)    (block session      ;; Get connection greeting.      (get-smtp-reply stream reply-line reply-code state)      (case reply-code((250 220))(:otherwise (setq state :bad-reply) (return-from session)))            ;; Identify this machine to server.      (send-smtp-command stream "HELO ~A~%" (send si:local-host :name))      (get-smtp-reply stream reply-line reply-code state)      (case reply-code((250 220))((500 501 504) (setq state :error-reply) (return-from session))(:otherwise (setq state :bad-reply) (return-from session)))            (loopwith max = (length (host-queue-message-alist host-queue))when (minusp (decf max)) return nil;avoid getting stuck here in case of a mail loop.for message-item in (host-queue-message-alist host-queue)do(block do-message  (setq message (car message-item))  (setq address-list (cdr message-item))  (setq delivered nil)  (when (null address-list)    (return-from do-message))  ;; Send return path  (send-smtp-command stream "MAIL FROM:<~A>~%"     (send (acceptable-return-path (send message :return-path))   :address-string))  (get-smtp-reply stream reply-line reply-code state)  (case reply-code    (250     )    ((552 451 452)     (return-from do-message))    ((500 501)     (dispose-host-queue-message host message-item :rejected (copy-seq reply-line))     (setq state :send-reset)     (return-from do-message))    (:otherwise     (dispose-host-queue-message host message-item :smtp-error (string-append "Bad response to MAIL command: " (copy-seq reply-line)))     (setq state :bad-reply)     (return-from session)))    (block do-recipients    (dolist (address address-list)      (send-smtp-command stream "RCPT TO:<~A>~%" (send address :address-string))            (get-smtp-reply stream reply-line reply-code state)      (case reply-code((250 251) (push address delivered))((550 551 552 553 554);554 is not allowed here by spec, but Ultrix sendmail uses it ;; Address failed, for now and forever (log-event :chaos-mail-client "Address ~A rejected by host ~A -- ~A" address host reply-line) (send message :dispose-address address :rejected host (copy-seq reply-line)) (delete address message-item))((450 451 452) ;; Address failed, might work later. But don't send more addresses and proceed to data (return-from do-recipients))((500 501 503) ;; Error.  Later code  will check if any recipients have been accepted so far ;; and if so, attempt to send data.  Otherwise the addresses for this host will be nuked. (return-from do-recipients))(:otherwise (dispose-host-queue-message host message-item :smtp-error     (string-append "Bad response to RCPT command: " (copy-seq reply-line))) (setq state :bad-reply) (return-from session)))))    (when (null delivered)    (log-debug :smtp-client "No recipients accepted by remote.")    (when (>= reply-code 500)      ;; No recipients accepted and got a high error code.  Give up on this message forever.      (dispose-host-queue-message host message-item :rejected (copy-seq reply-line)))    (setq state :send-reset)    (return-from do-message))  (with-open-stream (msg-stream (make-message-input-stream message))    (when (not (streamp msg-stream))      (setq state :send-reset)      (return-from do-message))    (send-smtp-command stream "DATA~%")    (get-smtp-reply stream reply-line reply-code state)    (case reply-code      (354       (setq state :data))      ((451 554)       (setq state :send-reset)       (return-from do-message))      ((500 501 503 421)       (setq state :send-reset)       (return-from do-message))      (:otherwise       (dispose-host-queue-message host message-item :smtp-error   (string-append "Bad response to DATA command: "  (copy-seq reply-line)))       (setq state :bad-reply)       (return-from session)))        (log-debug :smtp-client "-> [Send text]")    (loop      for line = (read-line msg-stream nil nil)      until (null line)      do      ;; Quote a period at beginning of line      (when (and (> (length line) 0) (eql (char line 0) #\.))(write-char #\. stream))      (write-line line stream)      finally      (log-debug :smtp-client "-> [Send <CRLF>.<CRLF>]")      (write-line "." stream)      (send stream :force-output)))    (get-smtp-reply stream reply-line reply-code state)  (case reply-code    (250     (log-event :smtp-client "Delivered ~A to host ~A for addresses ~{~A~^, ~}."message host delivered)     (dolist (address delivered)       (send message :dispose-address address :delivered host)       (delete address (the list message-item) :test #'eq)))    ((552 554 451 452)     (setq state :reset)     (return-from do-message))    (:otherwise     (dispose-host-queue-message host message-item :smtp-error (string-append "Bad response to end of data: " (copy-seq reply-line)))     (setq state :bad-reply)     (return-from session))));; End of DO-MESSAGE block(send message :update))      ;; End of loop for each message      (when (eq state :send-reset)(send-smtp-command stream "RSET~%")(get-smtp-reply stream reply-line reply-code state)(unless (eql reply-code 250)  (setq state :bad-reply)  (return-from session))(setq state :send-command)))    ;; Condition-call clauses  ((when (condition-typep condition 'sys:abort)     ;; Don't handle but do attempt cleanup.     (setq cleanup t)     nil))  ((handle-condition-p condition)   (setf (host-queue-last-error host-queue) condition)   (cond ((ignored-network-condition-p condition)  (log-debug :smtp-client "Ignored error sending to host ~A: ~A" host condition)  (setq cleanup nil)) (t  (setq cleanup t)  (mailer-error :smtp-client "SMTP client error while sending to host ~A:  ~A"host condition)))   condition)  (:no-error   (declare (ignore condition))   (setf (host-queue-last-error host-queue) nil)   (setq cleanup t)   nil))            ;; Unwind-protect forms      ;; Note that if in DATA state (we must be aborting), we are nasty and just close the stream.  The only      ;; other choice is to send the "." and then a QUIT, but then the server would think we had sent all the data!      (when (and cleanup (streamp stream) (neq state :data))(when (eq state :reply-wait)  (get-smtp-reply stream reply-line reply-code state))(send-smtp-command stream "QUIT~%")(get-smtp-reply stream reply-line reply-code state))      ;;(unless (eql reply-code 221)) ;;? what to do if bad reply returned here? just log and exit?      ;;Redundant.  Caller passes in stream so must close it too.      ;;(when (streamp stream)      ;;(send stream :close))      )))(defun DISPOSE-HOST-QUEUE-MESSAGE (host message-item &optional (disposition :delivered) report-string)    (let ((message (car message-item)))    (dolist (address (cdr message-item))      (send message :dispose-address address disposition host report-string))    (setf (cdr message-item) nil)))(defun ACCEPTABLE-RETURN-PATH (address)    (cond ((null address) (get-null-address))((bad-address-p address) (postmaster-address))(t address)))ents comments)   address-list))    (defmethod (GROUP-ADDRESS :NEW-ADD