LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031600. :SYSTEM-TYPE :LOGICAL :VERSION 7. :TYPE "LISP" :NAME "SERVER" :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 2758716057. :AUTHOR "REL3" :LENGTH-IN-BYTES 17374. :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.(defun REJECT-MAIL-CONNECTION-P ()  (cond ((eq (reject-mail) t) "Mail reception has been disabled for this machine.")((or (null *mail-queue*)     (not (send *mail-queue* :enabled-p))) "The Mail Daemon is currently disabled on this machine.")((not (file-system-usable-p 30)) "File system dismounted or almost full on this machine.")(t nil))      );; ;; CHAOS;;;;(add-initialization "MAIL" '(process-run-function '(:name "Mail Server" :priority -5);;   #'chaos-mail-server);;                    nil 'chaos:server-alist)(host:add-server-for-medium :chaos-stream "MAIL" '(process-run-function "MAIL Server"'chaos-mail-server))(defflavor mail-server-object   (conn    foreign-host)   (net:generic-peek-server-mixin)  :inittable-instance-variables)(defmethod (mail-server-object :host-object) ()  foreign-host)       (defmethod (mail-server-object :close) ()  (when conn    (send conn :send-if-handles :close)))(defun CHAOS-MAIL-SERVER ()    (let ((conn (chaos:listen "MAIL"))(user-id "Mailer")(*print-base* 10.)(*read-base* 10.)(*log-session* (incf *log-session*))(reject-reason (reject-mail-connection-p)) ;; Sadly, this may cause a namespace access before conn even acceptedfinal-ack-state)    (when reject-reason      (chaos:reject conn reject-reason)      (log-debug :chaos-mail-server "Rejected CHAOS mail connection: ~A" reject-reason)      (return-from chaos-mail-server))    (let* ((foreign-host "UNKNOWN")   line address ok message server-object)            (unwind-protect   (condition-call-if (not *debug-mailer*) (condition)      (block do-message(chaos:accept conn);;(send tv:who-line-file-state-sheet :add-server conn "MAIL")(with-open-stream (mail-stream (chaos:stream conn))  (setq foreign-host (or (si:get-host-from-address (chaos:foreign-address conn) :chaos) "UNKNOWN"))  (send si:current-process :set-priority -7)  (setq server-object (make-instance 'mail-server-object :conn conn :foreign-host foreign-host))  (send w:who-line-file-state-sheet :add-server server-object "MAIL")  (log-event :chaos-mail-server "Chaos MAIL Serving ~A" foreign-host)  (setq message (allocate-resource 'message))    ;; Get recipients  (loop    (setq line (read-line-with-timeout mail-stream t))    ;; Blank string indicates end of addresses    (if (string-blank-p line)(return))    (log-debug :chaos-mail-server "<- ~A" line)    ;; Create address object and validate address    (setq address (parse-address line 0 nil nil :mailbox))    (setq address (send address :remove-local-host))    (setq ok (and address (send address :accept-p)))    (cond (ok   (write-line "+Address valid." mail-stream)   (log-debug :chaos-mail-server "-> +Address valid.")   (send message :add-recipient address))  (address   (format mail-stream "-~A~%" (send address :rejection-report-string))   (log-debug :chaos-mail-server "-> -~A" (send address :rejection-report-string)))  (t   (write-line "-Invalid address." mail-stream)   (log-debug :chaos-mail-server "-> -Invalid address. (parsed to NIL)")))    (send mail-stream :force-output))  (log-debug :chaos-mail-server "<- [End Of Recipients]")  (send message :append-received-line foreign-host "CHAOS-NET" "CHAOS-MAIL")  ;; Copy text into message -- icky hack here to find return path since protocol does not provide it  (log-debug :chaos-mail-server "<- [Receive Text]")  (loop    with headers-end and found-from and header-type    with hop-count = 0    do    (multiple-value-bind (line eof)(read-line-with-timeout mail-stream nil nil)      (when (or eof (null line))(return))      (send message :line-out line)      (setq headers-end (or headers-end (string-blank-p line)))      (when (not headers-end)(setq header-type (header-line-type line))(cond ((and (not found-from)    (eq header-type :from))       (setq found-from t)       (send message :set-return-path     (parse-address line (header-line-body-index line) nil nil :route-address))       (log-debug :chaos-mail-server "Found From: field: ~A" (send message :return-path)))      ((eq header-type :received)       (when (> (incf hop-count) *max-message-network-hops*) (send message :set-loop-detected-p t)))      ((eq header-type :subject)       (send message :set-subject (header-line-body-string line)))))))  (log-debug :chaos-mail-server "<- [EOF]")  (let (result)    (if (null (send message :address-list));; Dont bother queuing if no recipients were valid.(deallocate-message message)      (when (null (send message :return-path))(log-debug :chaos-mail-server "No From: field found!  Using null return path")(send message :set-return-path (get-null-address)))      (setq result (enqueue-message message)))    (setq final-ack-state t)    (cond ((errorp result)   (format mail-stream "-~A~%" (sanitize-string (send result :report-string)))   (log-debug :chaos-mail-server "-> -~A  (error from ENQUEUE-MESSAGE)" result))  (t   (write-line "+Mail successfully sent" mail-stream)   (log-debug :chaos-mail-server "-> +Mail successfully sent")))    (send mail-stream :force-output))))        ;; condition-call clauses    ((handle-condition-p condition)     (unless (ignored-network-condition-p condition)       (mailer-error :chaos-mail-server "Chaos mail error while serving ~A~%~A" foreign-host condition))     (when final-ack-state       (log-event :chaos-mail-client "Error was during final ack.  This may cause a duplicate?!"))));; Unwind protect forms(when conn  (chaos:remove-conn conn))(when server-object  (send w:who-line-file-state-sheet :delete-server server-object))))    (force-log-output)));;(add-initialization "SMTP" '(process-run-function '(:name "Mail Server" :priority -20);;   #'chaos-smtp-server);;                    nil 'chaos:server-alist);;For Rel2 compat;;(host:add-server-for-medium :tcp-stream "SMTP" '(process-run-function "SMTP Server" 'smtp-mail-server));;(host:add-server-for-medium :chaos-stream "CHAOS-SMTP" '(process-run-function "CHAOS-SMTP Server" 'smtp-mail-server))(host:add-server-for-medium :byte-stream "SMTP" '(process-run-function "SMTP Server" 'smtp-mail-server))(defflavor smtp-server-object   (conn    foreign-host)   (net:generic-peek-server-mixin)  :inittable-instance-variables)(defmethod (smtp-server-object :host-object) ()  foreign-host)       (defmethod (smtp-server-object :close) ()  (when conn    (send conn :send-if-handles :close)))(defun SMTP-MAIL-SERVER (&optional stream)    (let ((state :send-reply)(cleanup nil)(error nil)(*read-base* 10)(*print-base* 10)(*log-session* (incf *log-session*))(user-id "Mailer")(command-string (allocate-xstring 4))command line message server-object foreign-host conn)        (setf (fill-pointer command-string) 4)        (unwind-protect(condition-call-if (not *debug-mailer*) (condition)    (block session      (unless stream(setq stream      (host:listen-for-connection-on-medium:byte-stream "SMTP":stream-type :ascii-translating-character-stream)))      (setq cleanup t)      (send si:current-process :set-priority -7)      (let ((reject-reason (reject-mail-connection-p)))(when reject-reason  (smtp-reply 421 stream reject-reason)  (setq state :quit)  (log-debug :smtp-server "Rejected connection: ~A" reject-reason)  (return-from session)))            (smtp-reply 220 stream)      (setq foreign-host (or (send stream :send-if-handles :foreign-host) "UNKNOWN"))      (setq conn (send stream :send-if-handles :connection))      (setq server-object (make-instance 'smtp-server-object :conn conn :foreign-host foreign-host))      (log-debug :smtp-server "SMTP serving ~A" foreign-host)      ;; May want to conditionalize the who line for Chaos vs. TCP serving      (send w:who-line-file-state-sheet :add-server server-object "SMTP")      (loop(setq state :command-wait)(setq line (read-line-with-timeout stream))(setq state :send-reply)(setq command (and (> (length line) 3)   (copy-array-portion line 0 4 command-string 0 4)   (intern (nstring-upcase command-string) *utility-package*)))(log-debug :smtp-server "<- ~A" line)(case command  (:HELO   (when message     ;; Must start with a clean message     (deallocate-message message))   (setq message (allocate-message))   (when (> (length line) 5)     (setq foreign-host (subseq line 5 (position #\Space line :start 5))))   (smtp-reply 250 stream))  (:MAIL   (let* ((address-start (position #\: (the string line)))  (address (and address-start (parse-address line (1+ address-start) nil nil :route-address))))     ;;? should verify return address?     (cond (address    (when message      ;; Must start with a clean message      (deallocate-message message))    (setq message (allocate-message))    (send message :set-return-path (send address :add-local-host))    (smtp-reply 250 stream))   (t    (smtp-reply 501 stream)))))    (:RCPT   (cond (message  (let* ((address-start (position #\: (the string line))) (address (and address-start       (parse-address line (1+ address-start) nil nil :route-address))))    (when address      (setq address (send address :remove-local-host)))    (cond ((send address :accept-p)   (send message :add-recipient address)   (smtp-reply 250 stream))  (address   (smtp-reply 550 stream (send address :rejection-report-string)))  (t   (smtp-reply 501 stream "No address found in RCPT command."))))) (t  (smtp-reply 503 stream "SMTP RCPT command must be preceeded by a MAIL command"))))    (:DATA   (log-debug :smtp-server "<- [Receive text]")   (cond (message  (send message :append-received-line foreign-host(or (send stream :send-if-handles :network-type) "UNKNOWN")"SMTP")  (smtp-reply 354 stream)  (setq state :data)  (loop    with headers-end and header-type    with hop-count = 0    for line = (read-line-with-timeout stream nil nil)    while line    do    (cond ((or (= (length line) 0)       (not (eql (char line 0) #\.)))   (send message :line-out line))  ;; Line starts with a dot -- if a "quoted dot" drop it  ((> (length line) 1)   (send message :line-out line 1))  ;; End of data  (t   (log-debug :smtp-server "<- [Received <CRLF>.<CRLF>]")   (return)))    (setq headers-end (or headers-end (string-blank-p line)))    (when (not headers-end)      (setq header-type (header-line-type line))      (cond ((eq header-type :received)     (when (> (incf hop-count) *max-message-network-hops*)       (send message :set-loop-detected-p t)))    ((eq header-type :subject)     (send message :set-subject (header-line-body-string line))))))  (setq state :send-reply)  (log-debug :smtp-server "Enqueue message.")  ;; Check if any recipients (client might be stupid and send data  ;;  even if no recipients were valid)  (let ((result (and (send message :address-list)     (enqueue-message message))))    (cond  ((errorp result)    (log-debug :smtp-server "Queue error: ~A" result)    ;; Assume errors at this point are transient    (smtp-reply 421 stream (sanitize-string (send result :report-string)))    ;;(setq state :quit) (setq message nil) (return-from session)    )   (t    (smtp-reply 250 stream)))    (setq message nil))) (t  (smtp-reply 503 stream "SMTP DATA command must be preceeded by MAIL and RCPT commands"))))    (:RSET   (when message     (deallocate-message message))   (setq message nil)   (smtp-reply  250 stream))    (:VRFY   (cond ((> (length line) 5)  (let* ((address (parse-address line 5 nil nil :route-address)) (ok (and address (send address :accept-p))))    (if ok(smtp-reply 250 stream (send address :string-for-message))      (smtp-reply 550 stream (send address :rejection-report-string))))) (t  (smtp-reply 501 stream "No address supplied for VRFY command"))))    (:NOOP   (smtp-reply 250 stream))    (:QUIT   (when message     (deallocate-message message))   (setq message nil)   (smtp-reply 221 stream)   (setq state :complete)   (return-from session))    (:HELP   (smtp-reply 214 stream))    ((:SEND :SOML :SAML :EXPN :TURN)   (smtp-reply 502 stream))    (:OTHERWISE   (smtp-reply 500 stream))  )))    ;; condition-call clauses  ((handle-condition-p condition)   (when message     (deallocate-message message))   (cond ((ignored-network-condition-p condition)  (log-debug :smtp-server "Error caught and ignored: ~A" condition)  (setq cleanup nil)) (t  (setq cleanup t)  (setq error t)  (when (condition-typep condition 'error)    (mailer-error :smtp-server "SMTP server error while serving host ~A~%~A"  foreign-host (send condition :report-string)))))))            ;; unwind-protect forms      (when (and cleanup (neq state :complete) (streamp stream))(case state   (:data   ;; Drain the data until we can send a reply   (loop until (null line) until (and (= (length line) 1)    (eql (char line 0) #\.)) do (setq line (read-line-with-timeout stream nil nil)))   (setq state :send-reply))  ((:command-wait :quit)   (setq line (read-line-with-timeout stream nil nil))));; At this point must be in a state to send a reply(loop  with count = 1  while line  do  (when (or (eq state :complete) (string-equal line "QUIT" :start1 0 :end1 4))    (smtp-reply 221 stream)    (return))  (if error      (smtp-reply 421 stream "~A closing transmission channel.  Local error.")    (smtp-reply 421 stream "~A closing transmission channel.  Need QUIT command." si:local-host))  ;; Give up after 10 attempts to quit  (when (>= (incf count) 10)    (return))  (setq line (read-line-with-timeout stream nil nil))))      (when server-object(send w:who-line-file-state-sheet :delete-server server-object)))    (force-log-output)))(DEFUN SMTP-REPLY (code stream &optional format-string &rest format-args)    (cond (format-string  (princ code stream)  (princ #\Space stream)  (apply #'format stream format-string format-args)  (terpri stream)  (log-debug :smtp-server  "-> ~D ~?" code format-string format-args))(t  (case code    (211      (if (reject-mail-connection-p)  (format stream "211 ~A Service available.~%" si:local-host)(format stream "211 ~A Service not available, Try again later.~%" si:local-host)))    (214      (write-line "214 Help" stream))    (220      (format stream "220 ~A service ready~%" si:local-host))    (221      (format stream "221 ~A Service closing transmission channel~%" si:local-host))    (250      (write-line "250 Requested mail action OK, completed." stream))    (354      (write-line "354 Start mail input; end with <CRLF>.<CRLF>" stream))    (421      (write-line "421 Service not available, Closing transmission channel." stream))    (450      (write-line "450 Requested mail action not taken: Mailbox unavailable." stream))    (451      (write-line "451 Requested action aborted: local error in processing." stream))    (452      (write-line "452 Requested action not taken: insufficient system storage." stream))    (500      (write-line "500 Syntax error, command unrecognized." stream))    (501      (write-line "501 Syntax error in parameters or arguments." stream))    (502      (write-line "502 Command not implemented." stream))    (503      (write-line "503 Bad sequence of commands." stream))    (504      (write-line "504 Command parameter not implemented." stream))    (550      (write-line "550 Requested action not taken: mailbox unavailable." stream))    (551      (write-line "551 User not local.  This machine only accepts local mail." stream))    (552      (write-line "552 Requested mail action aborted: exceeded storage allocation." stream))    (553      (write-line "553 Requested action not taken: mailbox name not allowed." stream))    (554      (write-line "554 Transaction failed." stream))    (otherwise      (ferror 'smtp-error "Internal Mailer error in SMTP-REPLY function: ~D is not a valid SMTP reply code" code)))  (log-debug :smtp-server "-> ~D" code)))  (send stream :send-if-handles :force-output))nts to go to the host it is queued