;;; -*- Mode: LISP; Syntax: Common-lisp; Package: POP3; Base: 10 -*-

;;; A POP3 server for Symbolics Genera.
;;; Mark Nahabedian



(net:define-protocol :pop3 (:pop :byte-stream)
  (:invoke (access-path)
    (declare (ignore access-path))
    (error "POP3 client not implemented")))

(defvar *pop3-server*)
(defvar *active-pop3-servers* nil)

(net:define-server :pop3 (:medium :byte-stream
			  :error-disposition :debugger	;for now
			  :address address
			  :host host
			  :stream (network-stream :accept-p t
						  :translation :ascii))
   (when *debugging-notify*
     (tv:notify nil "POP3 server invoked from ~s ~s" address host))
   (let ((si:*user* nil)
	 (*pop3-server* (make-instance 'symbolics-pop3-server :stream network-stream)))
     (unwind-protect
	 (progn
	   (push *pop3-server* *active-pop3-servers*)
	   (handler-case 
	     (start-pop3-server *pop3-server*)
	     (tcp::tcp-connection-reset ())))
       (setq *active-pop3-servers*
	     (delete *pop3-server* *active-pop3-servers*)))))

(tcp:add-tcp-port-for-protocol :pop3 110)

#|
()
;;; Add Services To Hosts pop tcp pop3 local
(cl-neti::com-add-services-to-hosts '((:POP :TCP :POP3)) (list net:*local-host*))
|#


(defmacro with-user-and-password ((user password) &body body)
  `(flet ((body () ,@body))
     (let ((si:*user* (user-object ,user))
	   (tried nil))
       (flet ((handler (condition)
		(unless tried
		  (setq tried t)
		  (send condition :proceed :password
			(user-name-string si:*user*) ,password))))
	 (handler-bind ((fs:login-required #'handler))
	   (body))))))

(defclass symbolics-pop3-server (pop3-server)
    ((password :accessor pop3-server-password)))

;;; mailer appends to existing mail.text file.
;;; what should be behavior toward "._ZMAIL_text" files?
;;; Ignore them for now, they're ZMAIL's province.
(defmethod user-mail-file-name ((server symbolics-pop3-server) user)
  (make-pathname :host (let ((mail-address (send user :mail-address)))
			 (second mail-address))
		 :directory (list :absolute (send user :string-for-printing))
		 :name "mail"
		 :type "text"			; "text"
		 :version :newest))

(defmethod check-user-password ((server symbolics-pop3-server) user password)
  (setf (pop3-server-password server) password)
  (with-user-and-password (user password)
    (handler-case
      (with-open-file (stream (user-mail-file-name server user)
			      :direction :input)
	(read-char stream))
      (fs:file-not-found () t))))

(defmethod message-to-stream :around ((server pop3-server) message stream
			      &optional number-of-lines) 
  (declare (ignore message stream number-of-lines))
  (with-user-and-password ((pop3-server-user server) (pop3-server-password server))
    (call-next-method)))

(defmethod get-mail-from-pathname :around ((server symbolics-pop3-server) pathname)
  (declare (ignore pathname))
  (with-user-and-password ((pop3-server-user server) (pop3-server-password server))
    (call-next-method)))

(defmethod server-update :around ((server symbolics-pop3-server))
  (with-user-and-password ((pop3-server-user server) (pop3-server-password server))
    (call-next-method)))

#|
()

(defun test-symbolics ()
  (let ((server (make-instance 'symbolics-pop3-server :stream *terminal-io*)))
    (setf (pop3-server-state server) :authorization)
    (catch 'quit-pop3
      (catch 'pop3-command-loop
	(pop3-server-do-one-command server "user hes")
	(pop3-server-do-one-command server "pass foo")
	(pop3-server-do-one-command server "quit")))))

|#

(defun user-name-string (user)
  (etypecase user
    (string user)
    (net:user (send (first (send user :names)) :string))))

(defun user-object (user)
  (etypecase user
    (string (net:find-object-named :user user))
    (net:user user)))