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

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



(define-condition pop3-condition (simple-error) ())
(define-condition command-not-valid (pop3-condition) ())
(define-condition client-command-error (pop3-condition) ())

(defclass pop3-server ()
    ((stream :initarg :stream :initform (error "no :STREAM supplied"))
     (state :initform nil :accessor pop3-server-state
	    :type (member :authorization :transaction :update nil))
     (user :accessor pop3-server-user)
     (mail-messages :initform (make-array 20 :adjustable t :fill-pointer 0))
     (highest-message-number-accessed :initform 0)
     ))

(defmethod highest-message-number-accessed ((server pop3-server) &optional number)
  (with-slots (highest-message-number-accessed) server
    (case number
      (:reset (setq highest-message-number-accessed 0))
      ((nil) highest-message-number-accessed)
      (t (when (> number highest-message-number-accessed)
	   (setq highest-message-number-accessed number))
	 highest-message-number-accessed))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; messages

(defclass pop3-message ()
    ((start-filepos :initarg :start)
     (end-filepos :initarg :end)
     (pathname :initarg :pathname :reader message-pathname)
     (deleted-p :initform nil :accessor message-deleted-p)))

(defmethod print-object ((object pop3-message) stream)
  (print-unreadable-object (object stream :type t :identity t)
    (with-slots (deleted-p pathname start-filepos end-filepos) object
      (format stream "~:[~;D ~]~a.~a.~a ~d-~d"
	      deleted-p
	      (ignore-errors (pathname-name pathname))
	      (ignore-errors (pathname-type pathname))
	      (ignore-errors (pathname-version pathname))
	      (ignore-errors start-filepos)
	      (ignore-errors end-filepos)))))

(defmethod pop3-message-length ((message pop3-message))
  (with-slots (start-filepos end-filepos) message
    (- end-filepos start-filepos)))

(defmethod message-to-stream ((server pop3-server) (message pop3-message) stream
			      &optional number-of-lines)
  (with-slots (start-filepos end-filepos pathname) message
    (with-open-file (mail-stream pathname
				 :direction :input
				 :element-type 'scl:string-char)
      (file-position mail-stream start-filepos)
      ;; first send header
      (loop (let ((line (read-line mail-stream)))
	      (write-line line stream)
	      (when (= (length line) 0)
		(return))))
      ;; now send specified number of body lines
      (let ((lines-sent 0))
	(loop (let ((line (read-line mail-stream)))
		(when (and number-of-lines (>= lines-sent number-of-lines))
		  (return))
		(write-line line stream)
		(incf lines-sent)
		(when (>= (file-position mail-stream) end-filepos)
		  (return))))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The server top-level

(defmethod start-pop3-server ((server pop3-server))
  (send-greeting server)
  (setf (pop3-server-state server) :authorization)
  (unwind-protect
      (catch 'quit-pop3
	(pop3-server-loop server))
    (pop3-server-cleanup server)))

;;; should this do the mail file updating?  What is the correct behavior
;;; if the network connection is lost during a session?
(defmethod pop3-server-cleanup ((server pop3-server)))

(defmethod send-greeting ((server pop3-server))
  (send-pop3-ok server "POP3 server on ~a" (send net:*local-host* :name)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; responses

(defmethod send-pop3-ok ((server pop3-server) &optional format-ctl &rest format-args)
  (with-slots (stream) server
    (write-string "+OK " stream)
    (when format-ctl
      (apply #'format stream format-ctl format-args))
    (terpri stream)
    (force-output stream)))

(defmethod send-pop3-error ((server pop3-server) &optional format-ctl &rest format-args)
  (with-slots (stream) server
    (write-string "-ERR " stream)
    (when format-ctl
      (apply #'format stream format-ctl format-args))
    (terpri stream)
    (force-output stream)))

(defmacro send-pop3-multi-line-response ((stream-var server &optional
						     format-ctl &rest format-args)
					 &body body)
  `(send-pop3-multi-line-response-1 ,server #'(lambda (,stream-var) ,@body)
				    ,format-ctl ,@format-args))

(defmethod send-pop3-multi-line-response-1 ((server pop3-server) body-fun
					    format-ctl &rest format-args)
  (with-slots (stream) server
    (write-string "+OK " stream)
    (when format-ctl
      (apply #'format stream format-ctl format-args))
    (terpri stream)
    (funcall body-fun stream)
    (write-string "." stream)
    (terpri stream)
    (force-output stream)))

(defmethod validate-message-number ((server pop3-server) message-number &key deleted-ok-p)
  (with-slots (mail-messages) server
    (unless (and (< 0 message-number)
		 (<= message-number (fill-pointer mail-messages)))
      (send-pop3-error server "~d is not a valid message number.  There are only ~d messages"
		       message-number (fill-pointer mail-messages))
      (throw 'pop3-command-loop nil))
    (let ((message (aref mail-messages (1- message-number))))
      (unless deleted-ok-p
	(when (message-deleted-p message)
	  (send-pop3-error server "Message ~d has beed deleted" message-number)
	  (throw 'pop3-command-loop nil)))
      message)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; command and argument parsing

(defun find-token (line start &key
			(leading-junk '(#\space #\tab)) (delimiter '(#\space #\tab)))
  (unless start
    (return-from find-token nil))
  (let ((start (position-if-not #'(lambda (char)
				    (member char leading-junk))
				line :start start)))
    (values start
	    (when start
	      (position-if #'(lambda (char)
			       (member char delimiter))
			   line :start start)))))

(defun get-number-arg (line index)
  (multiple-value-bind (start end)
      (find-token line index)
    (when start
      (parse-integer line :start start :end end :junk-allowed t))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; command loop

(defmethod pop3-server-loop ((server pop3-server))
  (with-slots (stream) server
    (loop
      (catch 'pop3-command-loop
	(handler-case
	  (pop3-server-do-one-command server (read-line stream))
	  (pop3-condition ())
	  (end-of-file ()
		       ;; connection must have gotten closed somehow.  Exit the
		       ;; server loop.  Don't save.  That should probably only
		       ;; happen when specifically requested by the user.
	    (return))
;	  (error (condition)
;		 (send-pop3-error server 
;				  (let ((*print-escape* nil))
;				    (format nil "~a" condition))))
	  )))))

(defmethod pop3-server-do-one-command ((server pop3-server) line)
  (multiple-value-bind (start end)
      (find-token line 0)
    (when (and start (zerop start))
      (let ((command (intern (string-upcase (subseq line start end)) :keyword)))
	(pop3-validate-command server command)
	(pop3-execute-command server command line end)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; check to make sure command is valid in the current context

(defun pop3-validate-command (server command)
  (pop3-validate-command-1 server (pop3-server-state server) command))

(defmethod pop3-validate-command-1 ((server pop3-server) state command)
  (send-pop3-error server "~a command not allowed in ~a state"
		   command state)
  (throw 'pop3-command-loop nil))

(defmacro command-valid (state command)
  `(defmethod pop3-validate-command-1 ((server pop3-server)
				       (state (eql ',state))
				       (command (eql ',command)))
     t))

(command-valid :authorization :user)
(command-valid :authorization :pass)
(command-valid :authorization :quit)
(command-valid :transaction :stat)
(command-valid :transaction :list)
(command-valid :transaction :retr)
(command-valid :transaction :dele)
(command-valid :transaction :noop)
(command-valid :transaction :last)
(command-valid :transaction :rset)
(command-valid :transaction :quit)
(command-valid :transaction :top)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; commands

(defmethod pop3-execute-command ((server pop3-server) command line data-index)
  (declare (ignore data-index))
  (error "~a command not implemented ~s" command line))

(defvar *debugging-notify* nil)

(defmethod pop3-execute-command :before ((server pop3-server) command line data-index)
  (declare (ignore command data-index))
  (when *debugging-notify* (tv:notify nil "POP3: ~s" line)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; session substrate

;;; implementations must specialize this.
(defmethod check-user-password ((server pop3-server) user password)
  (declare (ignore user password))
  nil)

;;; inplementations muyst specialize this.
(defgeneric user-mail-file-name (server user)
  (:documentation "Return the pathname of the user's incomming mail file"))

(defmethod message-separator-line-p ((server pop3-server) line)
  (and (= (length line) 1)
       (char-equal (aref line 0) #\or-sign)))

(defmethod write-message-separator-line ((server pop3-server) stream)
  (write-char #\or-sign stream)
  (terpri stream))

;;; return the pathname to rename the inbox to.
(defmethod get-mail-rename-pathname ((server pop3-server) pathname)
  (make-pathname :type "_ZMAIL_text"
		 :version :newest
		 :defaults pathname))

(defmethod get-mail-for-user ((server pop3-server))
  (with-slots (user mail-messages) server
    (assert user)
    (let* ((inbox-pathname (user-mail-file-name server user))
	   (rename-pathname (get-mail-rename-pathname server inbox-pathname)))
      (when (probe-file inbox-pathname)
	(rename-file inbox-pathname rename-pathname)
	(dolist (pathname (directory (make-pathname :version :newest
						    :defaults rename-pathname)))
	  (get-mail-from-pathname server pathname)))
      (fill-pointer mail-messages))))

(defmethod get-mail-from-pathname ((server pop3-server) pathname)
  (with-slots (mail-messages) server
    (handler-case 
      (with-open-file (mail-stream pathname
				   :element-type 'scl:string-char
				   :direction :input
				   :if-does-not-exist nil)
	(when mail-stream
	  (block done
	    (loop				;collect messages
	      (let ((start (file-position mail-stream)))
		(loop
		  (let* ((before (file-position mail-stream))
			 (line (read-line mail-stream nil nil))
			 (here (file-position mail-stream))
			 (separator? (message-separator-line-p server line)))
		    (when separator?
		      (setq here before))
		    (when (or (null line) separator?)
		      (unless (= start here)
			(vector-push-extend (make-instance 'pop3-message
							   :start start
							   :end here
							   :pathname pathname)
					    mail-messages))
		      (when (null line)
			(return-from done))
		      (return)))))))))
      (fs:file-not-found))))

(defmethod server-update ((server pop3-server))
  (with-slots (user mail-messages) server
    (let ((number-saved 0))
      (if (some #'message-deleted-p mail-messages)
	  (progn
	    (unless (every #'message-deleted-p mail-messages)
	      (with-open-file (file-stream (get-mail-rename-pathname
					     server (user-mail-file-name server user))
					   :direction :output
					   :element-type 'scl:string-char
					   :if-exists :supersede
					   :if-does-not-exist :create)
		(dotimes (i (fill-pointer mail-messages))
		  (let ((message (aref mail-messages i)))
		    (unless (message-deleted-p message)
		      (unless (zerop i)
			(write-message-separator-line server file-stream))
		      (message-to-stream server message file-stream)
		      (incf number-saved))))))
;;	    (let ((to-delete nil))
;;	      (dotimes (i (fill-pointer mail-messages))
;;		(pushnew (message-pathname (aref mail-messages i)) to-delete))
;;	      (mapc #'delete-file to-delete)
;;	      (when *debugging-notify*
;;		(tv:notify nil (format nil "to-delete: ~s" to-delete))))
	    (send-pop3-ok server "~d messages retained" number-saved))
	  (send-pop3-ok server "all messages retained")))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; session commands

;;; don't do any validation until after the PASS command.  The idea is
;;; to not give potential crackers any indication if the user is
;;; registered until a correct password is supplied.
(defmethod pop3-execute-command ((server pop3-server) (command (eql ':user)) line data-index)
  (let ((user-name (multiple-value-bind (start end)
		       (find-token line data-index)
		     (when start
		       (subseq line start end)))))
    (if user-name
	(progn
	  (send-pop3-ok server "~a" line)
	  (setf (pop3-server-user server)
		(net:find-object-named :user user-name nil)))
	(send-pop3-error server "no user name supplied ~s" line))))

(defmethod pop3-execute-command ((server pop3-server) (command (eql ':pass)) line data-index)
  (let ((password (multiple-value-bind (start end)
		      (find-token line data-index)
		    (when start
		      (subseq line start end)))))
    (with-slots (user) server
      ;; check to make sure a valid user was supplied and then validate
      ;; password.
      (unless (slot-boundp server 'user)
	(send-pop3-error server "no user specified")
	(throw 'pop3-command-loop nil))
      (if (and user (check-user-password server user password))
	  (progn (send-pop3-ok server "user ~a has ~d messages"
			       (send user :string-for-printing)
			       (get-mail-for-user server))
		 (setf (pop3-server-state server) :transaction))
	  (send-pop3-error server "user validation failure")))))

(defmethod pop3-execute-command ((server pop3-server) (command (eql ':quit)) line data-index)
  (declare (ignore line data-index))
  (when (eq :transaction (pop3-server-state server))
    (server-update server))
  (throw 'quit-pop3 nil))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; mail commands

(defmethod pop3-execute-command ((server pop3-server) (command (eql ':noop)) line data-index)
  (declare (ignore line data-index))
  (send-pop3-ok server "NOOP yourself"))

(defmethod pop3-execute-command ((server pop3-server) (command (eql ':last)) line data-index)
  (declare (ignore line data-index))
  (send-pop3-ok server "~d" (highest-message-number-accessed server)))

(defmethod pop3-execute-command ((server pop3-server) (command (eql ':rset)) line data-index)
  (declare (ignore line data-index))
  (highest-message-number-accessed server :reset)
  (with-slots (mail-messages) server
    (dotimes (i (fill-pointer mail-messages))
      (setf (message-deleted-p (aref mail-messages i)) nil)))
  (send-pop3-ok server "reset"))

(defmethod pop3-execute-command ((server pop3-server) (command (eql ':stat)) line data-index)
  (declare (ignore line data-index))
  (with-slots (mail-messages) server
    (send-pop3-ok server "~d ~d"
		  (fill-pointer mail-messages)
		  (let ((total 0))
		    (dotimes (i (fill-pointer mail-messages))
		      (incf total (pop3-message-length (aref mail-messages i))))
		    total))))

(defmethod pop3-execute-command ((server pop3-server) (command (eql ':dele)) line data-index)
  (let* ((message-number (get-number-arg line data-index))
	 (message (validate-message-number server message-number)))
    (with-slots (mail-messages) server
      (setf (message-deleted-p message) t)
      (send-pop3-ok server "message ~d deleted" message-number))))

(defmethod pop3-execute-command ((server pop3-server) (command (eql ':list)) line data-index)
  (let ((message-number (get-number-arg line data-index)))
    (with-slots (mail-messages stream) server
      (if message-number
	  (let ((message (validate-message-number server message-number)))
	    (if (message-deleted-p message)
		(send-pop3-error server "message ~d has been deleted" message-number)
		(send-pop3-ok server "~d ~d" message-number
			      (pop3-message-length message))))
	  (send-pop3-multi-line-response (stream server)
	    (dotimes (i (fill-pointer mail-messages))
	      (let ((message (aref mail-messages i)))
		(unless (message-deleted-p message)
		  (format stream "~d ~d~%"
			  (1+ i) (pop3-message-length message))))))))))

(defmethod pop3-execute-command ((server pop3-server) (command (eql ':retr)) line data-index)
  (let* ((message-number (get-number-arg line data-index))
	 (message (validate-message-number server message-number)))
    (send-pop3-multi-line-response (stream server "Here's message ~d" message-number)
      (message-to-stream server message stream))
    (highest-message-number-accessed server message-number)))

;;; the TOP command is an extension described in Marshall Rose's "The Internet Message"
(defmethod pop3-execute-command ((server pop3-server) (command (eql ':top)) line data-index)
  (multiple-value-bind (message-number new-index)
      (get-number-arg line data-index)
    (let ((number-of-lines (get-number-arg line new-index))
	  (message (validate-message-number server message-number)))
      (unless (>= number-of-lines 0)
	(send-pop3-error server "Bad number of lines: ~d" number-of-lines))
      (send-pop3-multi-line-response (stream server
					     "First ~d lines of message ~d"
					     number-of-lines message-number)
	(message-to-stream server message stream number-of-lines)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; testing

#|
(defun user::test-pop3 ()
  (declare (special server))
  (setq server (make-instance 'pop3-server :stream *standard-output*))
  (start-pop3-server server))
|#