LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031595. :SYSTEM-TYPE :LOGICAL :VERSION 10. :TYPE "LISP" :NAME "MESSAGE" :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 2758715967. :AUTHOR "REL3" :LENGTH-IN-BYTES 16777. :LENGTH-IN-BLOCKS 17. :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.;;;;;; MESSAGE related methods and functions for the mailer.;;;(defmethod (MESSAGE :STRING-OUT) (string &optional start end)  (unless text    (setq text (allocate-xstring 1000 500)))  (setq text (xsubstring string start end text))  nil)(defmethod (MESSAGE :LINE-OUT) (string &optional start end)  (unless text    (setq text (allocate-xstring 1000 500)))  (setq text (xsubstring string start end text))  (setq text (xstring-append text #\Return))  nil)(defmethod (MESSAGE :TYO) (char)  (unless text    (setq text (allocate-xstring 1000 500)))  (setq text (xstring-append text char))  nil)(defmethod (MESSAGE :APPEND-STRING) (&rest strings)  (unless text    (setq text (allocate-xstring 1000 500)))  (setq text (apply #'xstring-append text strings))  nil)(defmethod (MESSAGE :APPEND-LINE) (&rest strings)  (unless text    (setq text (allocate-xstring 1000 500)))  (when strings    (setq text (apply #'xstring-append text strings)))  (setq text (xstring-append text #\Return))  nil)(defmethod (MESSAGE :MESSAGE-ID-STRING) (&optional append-p (header-field-string "Message-ID:"))  (unless date-received    (setq date-received (get-universal-time)))  (unless tick-received    (setq tick-received (time)))  (let ((string (and append-p (allocate-xstring 100))))    (prog1      (format string "~@[~A ~]<~D-~D@~A>" header-field-string date-received tick-received (send si:local-host :name))      (when append-p(send self :append-line string)(deallocate-xstring string)))))(defmethod (MESSAGE :APPEND-RECEIVED-LINE) (from-host via with)  (unless date-received    (setq date-received (get-universal-time)))  (unless tick-received    (setq tick-received (time)))  (cond ((typep from-host 'si:basic-host) (setq from-host (send from-host :name)))((stringp from-host))(t (setq from-host "UNKNOWN")))  (send self :append-line "Received: From " from-host " By " (send si:local-host :name)" Via " (string via) " With " (string with) "; " (rfc822-date-string date-received)))(defsignal LOST-MESSAGE-TEXT (error mailer-error lost-message-text) ()  "Unexpected problem in chaos mail client protocol.")(defun MAKE-MESSAGE-INPUT-STREAM (message &optional verify-only errorp)    (let ((queue-path (send message :queue-path))(text (send message :text)))    (cond (verify-only   (if queue-path       (probe-file (send queue-path :new-type "MESSAGE"))     (stringp text)))  ((stringp text)   (make-string-input-stream text))  (queue-path   (open (send queue-path :new-type "MESSAGE") :error errorp))  (t   (funcall (if errorp #'ferror #'make-condition)    'lost-message-text    "Lost text for message.  No pathname or string for text in message instance ~S" message)))))(defmethod (MESSAGE :ADD-RECIPIENT) (address)  (unless (member address address-list :test #'address-equal)    (push-end address address-list)    (push-end address original-address-list)    (setq modified-p t)))(defmethod (MESSAGE :DISPOSE-ADDRESS) (address &optional (disposition :delivered) arg report-string)    (send address :set-delivery-status disposition arg report-string)  (with-lock (lock)    (setq address-list (delete address (the list address-list) :test #'eq))    (unless (or (eq disposition :translated)(eq disposition :expanded))      (push-end address disposed-address-list)      (unless (or (eq disposition :delivered)  (eq disposition :reject)  *interactive-delivery-in-progress*)(push (list address disposition arg report-string) error-return-list)))    (setq modified-p t)))(defmethod (MESSAGE :DELIVER) (&optional background)    (let ((*interactive-delivery-in-progress* t)(problems nil))    (block deliver      (cond ((eq (use-primary-mail-servers) :always)     ;; Just check for bad addresses and verify local recipients     (dolist (address address-list)       (cond ((bad-address-p address)      (send self :dispose-address address :bad-address nil (send address :error-report-string))      (setq problems t))     ((and (send address :local-p)   (not (send address :verify)))      (send self :dispose-address address :verify-error nil    (send address :verification-report-string))      (setq problems t)))))    (t     (setq problems   (not (send self :translate-addresses :expand t :forward t :verify t :canonical t)))))      (when (null address-list)(format t "~2%No addresses remaining after verification.  Message not sent.")(return-from deliver))      (when problems(let ((*query-io* *terminal-io*));;for ZMACS... don't want to prompt in the minibuffer  (unless (y-or-n-p "~&Send message anyway?")    (return-from deliver))))      ;; Take care of local addresses immediately (even if told to do in background)      (send self :direct-delivery)      (when (not background);; Fake up a queue and make one delivery attempt.  Catch abort.(condition-case ()    (using-resource (queue temp-mail-queue)      (send queue :add-message self nil)      (send queue :deliver))  (sys:abort   (let ((*query-io* *terminal-io*))     (unless (y-or-n-p "~2%Foreground delivery aborted.  Deliver in background?")       (format t "~2%Delivery aborted.")       (return-from deliver))))))      (when address-list(enqueue-message self nil))      t)))(defmethod (MESSAGE :DELIVERY-COMPLETE-P) ()  (and (null address-list)       (null error-return-list)))(defmethod (MESSAGE :TRANSLATE-ADDRESSES) (&key expand forward strip-local verify canonical)    (unless expanded-p    (setq expanded-p t)    (let ((all-ok t)  translation expansion mailing-lists)      (declare (list expansion mailing-lists))      (when expand (dolist (address address-list)  (setq translation (send address :expand-mailing-list))  (when (consp translation)    (push address mailing-lists)    (setq expansion (nconc translation expansion))));; Note that mailing lists come last (which the following loop is dependent on)(setq address-list (nconc address-list expansion)))      (loop with address-that-expandedfor address-tail on address-listfor address = (car address-tail)do(cond ((member address mailing-lists :test #'eq)       ;; This address was a mailing list; delete original and check its members       (setq address-that-expanded address)       (send self :dispose-address address :expanded))      (t(setq translation (send address :translate:forward forward :strip-local strip-local :canonical canonical))(when (neq address translation)  ;; Replace address with its expansion  (setf (car address-tail) translation)  (setq address translation));Verify if told to, but assume that mailing list members always need verification(cond ((or (and (not verify)(not address-that-expanded))   (send address :verify))       ;; address is ok, leave on list       )      (t;; Verify failed, if interactive maybe forward to server (unless this machine *is* a server)(if (and *interactive-delivery-in-progress* (eq (use-primary-mail-servers) :unknown-addresses))    ;; Keep address, make note of forwarding    (send address :set-delivery-status :forward-unknown)  ;; Drop address, make note if address was a mailing list member.  (setq all-ok nil)  (if address-that-expanded      (send self :dispose-address address :expansion-error address-that-expanded    (send address :verification-report-string))    (send self :dispose-address address :verify-error nil  (send address :verification-report-string)))))))))      all-ok)))(defmethod (MESSAGE :FLUSH) ()  (when (and queue-path (not *interactive-delivery-in-progress*))    (send queue-path :delete nil)    (send (send queue-path :new-type "MESSAGE") :delete nil)    (deallocate-message self)))(defmethod (MESSAGE :UPDATE) (&optional force)    (when (and (not *interactive-delivery-in-progress*)     queue-path     (or force modified-p))    (cond ((or (send self :delivery-complete-p)       (not (probe-file queue-path))       (not (probe-file (send queue-path :new-type "MESSAGE"))))   ;; File(s) have vanished or delivery is complete -- delete files and remove from queue   (when *mail-queue*     (send *mail-queue* :dispose-message self)))  (t   (send self :save)))))(defmethod (MESSAGE :SAVE) ()  "Save message to disk the first time.  Afterwards use :UPDATE toreflect changes in message on disk."    (with-lock (lock)    (let ((dir (mailer-directory)))      (unless (probe-file (send dir :directory-pathname-as-file))(fs:create-directory dir)))        (setq modified-p nil)    (unless date-received      (setq date-received (get-universal-time))      (setq tick-received (time)))    (unless queue-path      ;; First time saved -- generate queue pathname and write message file      (using-xstring (string 30)(format string "~D-~D" date-received tick-received)(setq queue-path (send (mailer-directory) :new-pathname       :name string       :type "WORK"       :version :newest)))      (with-open-file (text-out (send queue-path :new-type "MESSAGE"):direction :output :characters t)(stream-copy-until-eof (make-message-input-stream self) text-out)))    (with-open-file (queue-out queue-path       :direction :output :characters t :if-exists :supersede)      (format queue-out "(~%  (:RETURN-PATH ~S)~%" (send return-path :string-for-message))      (format queue-out "  (:EXPANDED-P ~S)~%" expanded-p)      (format queue-out "  (:DATE-RECEIVED ~D)~%" date-received)      (format queue-out "  (:TICK-RECEIVED ~D)~%" tick-received)      (when first-notification-sent(format queue-out "  (:FIRST-NOTIFICATION-SENT T)~%"))      (dump-list :ADDRESS-LIST address-list queue-out)      (when disposed-address-list(dump-list :DISPOSED-ADDRESS-LIST disposed-address-list queue-out))      (when error-return-list(dump-list :ERROR-RETURN-LIST error-return-list queue-out))      (write-line ")" queue-out))))(defun DUMP-LIST (symbol list stream)    (format stream "  (~S ~%" symbol)  (dolist (thing list)    (cond ((address-p thing)   (format stream "    ~S~%" (send thing :address-string)))  ((consp thing)   (princ "    (" stream)   (dolist (sub-thing thing)     (cond ((address-p sub-thing)    (format stream "~S " (send sub-thing :address-string)))   ((typep sub-thing 'host:host)    (format stream "~S " (send sub-thing :name)))   (t     (format stream "~S " sub-thing))))   (write-line ")" stream))))  (format stream "  )~%"))(defmethod (MESSAGE :RESTORE) (stream pathname)    (let ((work nil))    (setq queue-path (send pathname :new-version :newest))    (setq work (read stream))    (dolist (work-item work)      (case (car work-item)(:return-path  (setq return-path (parse-address (cadr work-item) 0 nil nil :route-address)))((:expanded-p :first-notification-sent :date-received :tick-received) (send self :set (car work-item) (second work-item)))(:address-list  (setq address-list (mapcar #'parse-address (cdr work-item))))(:disposed-address-list  (setq disposed-address-list (mapcar #'parse-address (cdr work-item))))(:error-return-list  (setq error-return-list (cdr work-item))  (dolist (error-item error-return-list)     (setf (car error-item) (parse-address (car error-item)))))(:otherwise  (ferror 'mailer-error "Unknown keyword ~S found in mailer work file." work-item))))))(defmethod (MESSAGE :RETURN-ERRORS) ()    (with-lock (lock)    (let* ((time (get-universal-time))   (interval (- time date-received))   first-timeout final-timeout)      (setq first-timeout (and (not first-notification-sent)       (> interval (* 60 60 *initial-message-timeout-hours*))))      (setq final-timeout (> interval (* 60 60 *final-message-timeout-hours*)))            (when (or error-return-list (and address-list     (or first-timeout final-timeout)))(log-event :mail-queue "Returning notification for ~S~@[ -- ~A~] -- Errors: ~S"   self   (cond (final-timeout "Final timeout") (first-timeout "First timeout"))   error-return-list)(setq first-notification-sent t)(let* ((message (allocate-message))       (return-address (and return-path (send return-path :remove-local-host)))       (path-ok (and return-address (send return-address :verify))))  ;; If first notification and can't follow return path, do nothing  (unless (and first-timeout (not path-ok))    (cond (path-ok   ;; Just make sure it doesn't print as a route address in the header    (setq return-address (send return-path :new-address :type :mailbox)))  ((null-address-p return-path)   ;; Last gasp, dump it to the mailer directory   (setq return-address nil))  ;; Have return path but its no good... try to get help  (t   (setq return-address (send (postmaster-address) :translate :expand t :forward t))))        (send message :message-id-string t)    (send message :append-line "Date: " (rfc822-date-string (get-universal-time)))    (send message :append-line "From: " (send (mailer-daemon-address) :string-for-message))    (when return-address      (send message :add-recipient return-address)      (send message :append-line "To: " (send return-address :string-for-message)))    (send message :append-line "Subject: Problem in mail delivery")    (send message :append-line)    (send message :append-line "   ----- Notification from host: " (send si:local-host :name))    (send message :append-line)    (when (and return-address return-path (not path-ok))      (send message :append-line "   ----- Unable to return this notification to: "    (send return-path :string-for-message))      (send message :append-line "   ----- Forwarding to Postmaster for assitance.")      (send message :append-line))        (when error-return-list      (send message :append-line "   ----- Mail not delivered to the following addresses:")      (loopfor status in error-return-listdo(apply #'print-address-disposition message status))      (setq error-return-list nil)      (send message :append-line)      (send message :append-line))        (when (and address-list       (or first-timeout final-timeout))      ;; Drop the minutes and seconds from the message      (setq interval (- interval (mod interval (* 60 60))))      (send message :append-line "   ----- After " (time:print-interval-or-never interval nil))      (send message :append-line "   ----- your message has not been delivered to the following addresses.")      (dolist (address address-list)(send message :line-out (send address :string-for-message)))      (cond (first-timeout     (let ((remaining (- (* 60 60 *final-message-timeout-hours*) interval)))       (send message :append-line "   ----- Attempts to deliver will continue for another "     (time:print-interval-or-never remaining nil))))    (t     (send message :append-line "   ----- There will be no further attempts to deliver.")))      (send message :append-line))        (with-open-stream (msg-in (make-message-input-stream self))      (cond ((errorp msg-in)     (format message "   ----- Lost text for message!  ~A~%" msg-in))    (first-timeout     (send message :append-line "   ----- Your message begins as follows:")     (format message "Return-Path: <~A>~%" (or return-path ""))     (using-xstring (msg-string 1200)       (send msg-in :string-in nil msg-string 0 800)       (send message :string-out msg-string)))    (t     (send message :append-line "   ----- Unsent message follows:")     (format message "Return-Path: <~A>~%" (or return-path ""))     (stream-copy-until-eof msg-in message))))        (send message :set-return-path (get-null-address))    (if return-address(enqueue-message message)      (direct-delivery message (mailer-daemon-address))      (deallocate-message message))    (setq modified-p t)    (cond (first-timeout   (setq first-notification-sent t))  (final-timeout   ;;clear the address list so message will be deleted   (setq address-list nil)))))))))when create-p(let ((host-queue (make-host-queue :contact contact)))  (send mail-queue :set-host-queue-list(nconc (send mail-queue :host-queue-list)       (list host-queue)))  host-queue))))(defmethod (MAIL-QUEUE :DISPOSE-MESSAGE) (message)  (send message :flush)  (with-lock (lock)    (setq message-list (delete message (the list message-list) :test #'eq)))  (dolist (host-queue host-queue-list)    (host-queue-delete-message host-queue message)))(defmethod (MAIL-QUEUE :CHECK-ROUTING) ()    (when    ;; Loop thru the host queues checking if each address    ;; still wants to go to the host it is queued