;;;-*- Mode:Common-Lisp; Package:MAIL; Base:10 -*-

;;; **********************************************************************
;;; Copyright (c) 1990 Stanford University.
;;; This code was written by James Rice.
;;; Copyright is held by Stanford University except where code has been
;;; modified from TI source code.  In these cases TI code is marked with
;;; a suitable comment.

;;; All Stanford Copyright code is in the public domain.  This code may be
;;; distributed and used without restriction as long as this copyright
;;; notice is included and no fee is charged.  This can be thought of as
;;; being equivalent to the Free Software Foundation's Copyleft policy.

;;; TI source code may only be distributed to users who hold valid TI
;;; software licenses.

;;; The development of this software was assisted by the following grants:
;;; Biomedical Research Technology Program of the National Institutes
;;; of Health under grant RR-00785
;;; Information Systems Technologies office of the Defense Advanced
;;; Research Projects Agency under contract N00039-86-C0033.

;;; **********************************************************************


;;; Modified TI code.
(defun execute-smtp-command-on-stream (host stream message)
"Given a host object, a tcp stream and a command message, executes the command
on host Host, using stream Stream.  Returns a string which was the reply to the
command.
"
  (let ((*print-base* 10)
	(*read-base* 10)
	(state :reply-wait)
 	reply-line reply-code cleanup final-reply)
    (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)))
	      (send-smtp-command stream "~A~%" message)
	      (case reply-code
		((250 220))
		((500 501 504)
		 (setq state :error-reply)
		 (return-from session))
		(:otherwise
		 (setq state :bad-reply)
		 (return-from session)))
	      (setq final-reply
		    (copy (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)))
	      (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)
	   (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))
	   (setq cleanup t)
	   final-reply))
      ;; 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))
      )
    final-reply
  )
)


(defun remove-smtp-status-codes (string &optional (index 0))
"Given a string and a start index, returns a string that has no SMTP
status codes at the beginning of its lines.
"
  (let ((newline (position #\newline string :Start index :Test #'char-equal)))
       (if newline
	   (string-append (subseq string (+ index 4) newline) #\newline
			  (remove-smtp-status-codes string (+ 1 newline))
	   )
	   (subseq string (+ 4 index))
       )
  )
)

(defun execute-smtp-command (host message)
"Executes an SMTP command on Host.  For instance, you might call
  (execute-smtp-command \"sumex\" \"expn rice\")
to get the who expansion of rice@sumex.
"
  (with-open-stream
    (stream (host:open-connection-on-medium
	      (net:parse-host host)
	      :byte-stream "SMTP"
	      :stream-type :ascii-translating-character-stream
	      :error nil
	      :timeout (if *interactive-delivery-in-progress*
			   (* 15 60)
			   (* 60 60))))
    (Remove-Smtp-Status-Codes
      (Execute-Smtp-Command-On-Stream host stream message)
    )
  )
)


(defun who (host name)
"Gets the WHO expansion of Name on the host Host."
  (execute-smtp-command host (string-append "expn " name))
)


;(print (who "sumex" "info-ti-explorer"))


;(print (who "sumex" "wr-help"))