;;; -*- Mode:Common-Lisp; Package:IMAP; 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.

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

;===============================================================================
;;; Not implemented yet:  Eight-Bit-Transparent.

;===============================================================================

;;; Define server special vars.

(define-server-special-variable *all-mailboxes* nil)
(define-server-special-variable *current-mailbox* nil)
(define-server-special-variable *selected-features*
  (protocol-version-default-features *server-default-version*)
)
(define-server-special-variable *selected-version* *server-default-version*)
;-------------------------------------------------------------------------------

(defun ~command-p (command)
  "Is true if command is the name of a ~ command."
  (equal #\~ (aref (symbol-name command) 0))
)

(defun not-ify (command)
  "Given the name of a command returns the not command."
  (or (get command :~command)
      (progn (setf (get command :~command)
		   (if (~command-p command)
		       (Intern (format nil "~A" (subseq command 1)) 'keyword)
		       (Intern (format nil "~~~A" command) 'keyword)
		   )
	     )
	     (Not-ify command)
      )
  )
)

(defun not-ify-versions ()
"Makes sure that all of the declared version also know about
all of the ~ features.
"
  (loop for version in *Imap-Server-Supported-Versions*
	do (setf (protocol-version-supported-features version)
		 (loop for feature
		       in (protocol-version-supported-features version)
		       append (if (~command-p feature)
				  nil
				  (list feature (Not-ify feature))
			      )
		 )
	   )
  )
)

;;; Make sure all of the versions also include the ~ versions.
(Not-ify-Versions)

(defun feature-enabled-p (feature)
"Is true when a feature is enabled."
  (member feature *Selected-Features* :Test #'eq)
)

(defun imap-server-top-level-read-line (stream)
  "The part of the server that reads the first line from the user."
  (let ((*readtable* yw:*IMAP-ReadTable*))
       (let ((line-temp (read-line stream nil :Eof)))
	    (if (equal line-temp :Eof)
		line-temp
		(string-append line-temp #\newline)
	    )
       )
  )
)

(Defun imap-server-top-level (stream)
"The top level function for the IMAP server.  Is passed the IMAP stream."
  (Send-Unsolicited-Command stream :Ok 
    (format nil "~A IMAP server." (send si:local-host :Name))
  )
  (binding-server-special-variables
    (loop for line = (if (feature-enabled-p :New.Mail.Notify)
			 (with-timeout
			   ((* *imap-server-new-mail-check-interval* 60)
			    :Timeout
			   )
			   (imap-server-top-level-read-line stream)
			 )
			 (imap-server-top-level-read-line stream)
		     )
	  until (equal :Eof line)
	  do (if (equal :Timeout line)
		 (if *Current-Mailbox*
		     (Process-Imap-Server-Command stream :Unsolicited :Check)
		     nil
		 )
		 (Imap-server-top-level-1 line stream)
	     )
    )
  )
)

(defun barf (stream &rest format-args)
"Gives an IMAP BAD response."
  (Send-Unsolicited-Command
    stream :Bad (apply #'format nil (or format-args '("")))
  )
)

(defun imap-server-top-level-1 (line stream)
"One level down from the top level of the IMAP server.  Line is a line
read in from the client from Stream.
"
  (multiple-value-bind (command error-p arglist tag)
      (parse-imap-command-line line stream)
    (if error-p
	(barf stream "Illegal command syntax.")
        (multiple-value-bind (success-code string continuation)
	    (apply 'process-imap-server-command
		   stream tag command arglist
	    )
	  (format stream "~A ~A ~A~%" tag success-code (or string ""))
	  (force-output stream)
	  (if continuation
	      (funcall continuation stream)
	      nil
	  )
	)
    )
  )
)

(defun parse-imap-command-line (line stream)
"Parses a command line from Stream.  Line may not be complete because
of literals but will be most of the time.
"
  (multiple-value-prog1 ;catch-error ;;; {!!!!}
    (multiple-value-bind (command args tag)
	(parse-imap-command-line-1 line stream)
      (values command nil args tag)
    )
    nil
  )
)

(defun parse-imap-command-line-1 (line stream)
"Internal function for parsing IMAP command lines."
  (with-input-from-string (string-stream line)
    (let ((str (make-concatenated-stream string-stream stream)))
         (let ((tag (let ((*package* (find-package 'imap-tags))) (read str)))
	       (command (let ((*package* (find-package 'keyword))) (read str)))
	      )
	      (values command (process-request command str) tag)
	 )
    )
  )
)

(defun read-space (stream &optional (no-error-p nil))
"Reads a space character from the IMAP stream.  Gives errors for
non-spaces unless no-error-p is true.
"
  (let ((char (read-char stream nil :eof)))
       (if (equal :Eof char)
	   (if no-error-p
	       nil
	       (ferror nil "End of file encountered.")
	   )
	   (if (char-equal #\space char)
	       t
	       (if no-error-p
		   (unread-char char stream)
		   (ferror nil "~S is not a space." char)
	       )
	   )
       )
  )
)
	      
(defun read-string (stream)
"Reads a string from Stream.  The string can be an atom, a quoted string or a
literal.
"
  (read-space stream t)
  (let ((char (read-char stream)))
       (unread-char char stream)
       (case char
	 (#\{ (read-literal stream))
	 (#\" (read-quoted-string stream))
	 (otherwise (read-atom stream))
       )
  )
)

(defun read-keyword (stream)
"Reads a keywords from the stream (atom)."
  (Skip-Whitespace stream)
  (let ((string (Read-Atom stream)))
       (intern (string-upcase string) 'keyword)
  )
)

(defun read-until (stream char-set)
"Reads characters from Stream until it encounters one of the char in char-set.
Returns a string with the chars read.
"
  (let ((chars (loop for char = (read-char stream nil :eof)
		     until (or (equal char :Eof)
			       (member char char-set :Test #'char=)
			   )
		     collect char
		     finally (or (equal char :Eof) (unread-char char stream))
	       )
	)
       )
       (make-array (length chars) :Element-Type 'string-char
		   :Initial-Contents chars
       )
  )
)

(defun read-atom (stream)
"Reads an atom from the stream."
  (Read-Until stream '(#\space #\return #\newline #\)))
)

(defun read-quoted-string (stream)
"Reads a quoted type string from the stream.  The opening quote has already
been read in.
"
  (read-char stream) ;;; The openning quote.
  (let ((string (Read-Until stream '(#\"))))
       (read-char stream) ;;; closing quote
       string
  )
)

(defun read-literal (stream)
"Reads a literal string from the stream.  The open { char has already been
read in.
"
  (read-char stream) ;; the openning brace.
  (let ((length
	  (let ((*read-base* 10.))
	       (read-from-string (Read-Until stream '(#\})))
	  )
	)
       )
       (read-char stream) ;;; }
       (read-char stream) ;;; CRLF
       (let ((result-string (make-array length :Element-Type 'string-char)))
            (loop for count from 0 below length
		  for char = (read-char stream)
		  do (setf (aref result-string count) char)
	    )
	    result-string
       )
  )
)

(defun read-number (stream)
"Reads a decimal number from stream."
  (Read-Space stream t)
  (let ((result 0))
       (loop for char = (read-char stream nil :eof)
	     while (yw:number-char-p char)
	     do (setq result
		      (+ (* result 10) (- (char-int char) (char-int #\0)))
		)
	     finally (or (equal char :Eof) (unread-char char stream))
       )
       result
  )
)

(defun read-maybe-number-range (stream)
"Reads a number range like nnn:nnn from stream."
  (Read-Space stream t)
  (if (yw:number-char-p (peek-char nil stream nil :eof))
      (let ((first (Read-Number stream)))
	   (let ((next-char (peek-char nil stream nil :eof)))
	        (if (equal next-char #\:)
		    (progn (read-char stream) ;;; Discard the colon char.
			   (list first (Read-Number stream))
		    )
		    first
		)
	   )
      )
      nil
  )
)

(defun read-sequence (stream)
"Reads in specification of a sequence of messages from Stream.  This can be
any number of message numbers separated by , chars or : chars.
"
  (let ((current-number (Read-Number stream))
	(next-char (read-char stream))
       )
       (case next-char
	 (#\, (cons current-number (read-sequence stream)))
	 (#\: (let ((next-number (Read-Number stream)))
		   (append (loop for i from current-number to next-number
				 collect i
			   )
			   (if (char= #\, (peek-char nil stream))
			       (read-sequence stream)
			       nil
			   )
		   )
	      )
	 )
	 (otherwise (unread-char next-char stream) (list current-number))
       )
  )
)

(defun skip-whitespace (stream)
"Skips any whitespace on stream."
  (loop for char = (read-char stream)
	while (member char '(#\space #\newline) :Test #'char=)
	do nil
	finally (unread-char char stream)
  )
)

(defun read-sexpression (stream)
"Reads an IMAP sexpression from stream.  This could be a string, a
list or an atom.
"
  (skip-whitespace stream)
  (let ((char (peek-char nil stream)))
       (case char
	 ((#\" #\{) (Read-String stream))
	 (#\( (read-char stream) ;;; the openning paren
	      (let ((result (loop for char = (peek-char nil stream)
				  until (char= char #\))
				  collect (read-sexpression stream)
			    )
		    )
		   )
		   (read-char stream) ;;; The closing paren
		   result
	      )
	 )
	 (otherwise
	  (if (and (feature-enabled-p :Indexable.Fields)
		   (Yw:number-char-p char)
	      )
	      (Read-Maybe-Number-Range stream)
	      (Read-Atom stream)
	  )
	 )
       )
  )
)

(defun Number-Of-Messages-In
       (&optional
        (in (locally (declare (special *current-mailbox*)) *current-mailbox*))
       )
"Returns the numbers of messages in the mailbox IN."
  (array-active-length (mail-file-messages in))
)

(defun the-message (index mailbox)
"Returns the message indexed by Index in Mailbox."
  (aref (mail-file-messages mailbox) (- index 1))
)

(defmethod (setf The-Message) (new-value index mailbox)
"Sets the message indexed by Index in Mailbox to New-Value."
  (setf (aref (mail-file-messages mailbox) (- index 1)) new-value)
)

(defun flag-set-p (flags flag?)
"Is true if the flag Flag? is set in the flag list Flags."
  (let ((entry (assoc flag? flags :Test #'eq)))
       (and entry (second entry))
  )
)

(defun set-flag (mailbox message flag set-p)
"Sets the flag Flag to the value Set-p in the message Message in the current
mailbox.
"
  (let ((flags (message-flags message)))
       (let ((entry (assoc flag flags :Test #'eq)))
	    (if entry
		(if (or (and set-p (second entry))
			(and (not set-p) (not (second entry)))
		    )
		    nil
		    (progn (setf (second entry) set-p)
			   (set-flags-in-mail-file message
			     flags (mail-file-keywords mailbox)
			     (mail-file-format mailbox)
			   )
			   (setf (mail-file-modified-p mailbox) t)
		    )
		)
		nil
	    )
       )
       flags
  )
)

(defun decode-flags (flags)
"Given a flag alist returns the list of enabled flags."
  (loop for (name set-p) in flags when set-p collect name)
)

(defun recent-p (message)
"Is true if the message is recent."
  (flag-set-p (message-flags message) :\\Recent)
)

(defun deleted-p (message)
"Is true if the message is deleted."
  (flag-set-p (message-flags message) :\\Deleted)
)

(defun translate-mailbox-name (name)
"Turns the mailbox name Name into a canonical name of the server.  This
involves translating any entries in *all-mailbox-name-translations*.
"
  (let ((entry (assoc name *all-mailbox-name-translations* :Test #'equal)))
       (if entry
	   (second entry)
	   name
       )
  )
)

(defun find-open-mailbox (name)
  "Finds an existing open mailbox called Name."
  (declare (values mailbox real-name-of-mailbox))
  (let ((real-name (translate-mailbox-name name)))
       (values (find-if #'(lambda (box)
			    (equal real-name (mail-file-name box))
			  )
			*all-mailboxes*
	       )
	       real-name
       )
  )
)

(defun find-or-open-mailbox (name &optional (merge-pathname nil))
"Finds or Opens a mailbox object for Name."
  (declare (special *all-mailboxes*))
  (multiple-value-bind (existing real-name) (Find-Open-Mailbox name)
    (or existing
	(let ((new (parse-mail-file
		     (if merge-pathname
			 (fs:merge-pathnames real-name merge-pathname)
			 real-name
		     )
		     (compute-mail-file-format real-name)
		   )
	      )
	     )
	     (push new *all-mailboxes*)
	     new
	)
    )
  )
)

(defun count-recent-messages (mailbox)
"Counts the messages that are deemed recent in the mailbox Mailbox."
  (let ((count 0))
       (loop for index from (Number-Of-Messages-In mailbox) downto 1 do
	     (if (recent-p (the-message index mailbox))
		 (setf count (+ 1 count))
		 (return nil)
	     )
       )
       count
  )
)

(defun send-unsolicited-command (stream command &rest args)
"Sends an unsolicited command to the client on Stream."
  (apply 'Send-Solicited-Command stream :* command args)
)

(defun finish-solicited-command (stream)
"Finishes trhe sending of a solicited command on Stream."
  (format stream "~%")
  (force-output stream)
)

(defun send-solicited-command (stream tag command &rest args)
"Sends a solicited command to the client on Stream with the tag Tag."
  (apply 'send-solicited-command-start stream tag command args)
  (finish-solicited-command stream)
)

(defun send-solicited-command-start (stream tag command &rest args)
"Sends the initial part of a solicited response to the client on Stream
with the tag Tag.
"
  (if (and (boundp '*selected-version*)
	   (not (equal *Selected-Version* *imap2-version*))
	   (feature-enabled-p :Tagged.Solicited)
	   (not (equal tag :Unsolicited))
      )
      (format stream "~A " tag)
      (format stream "* ")
  )
  (apply 'Send-Solicited-Command-Component stream command args)
)

(defun count-newlines (in)
"Counts the newlines in the string In."
  (let ((count 0)
	(index 0)
       )
       (loop for position = (position #\newline in :Test #'char= :Start index)
	     while position
	     do (setq index (+ 1 position))
	        (setq count (+ 1 count))
       )
       count
  )
)

(defun send-string (stream string)
"Sends a string to the client over Stream."
  (if (string-search-set yw:*IMAP.Arg-Breaks* string)
      (progn (format stream "{~D}~%"
		     (+ (Count-Newlines string) (length string))
	     )
	     (princ string stream)
      )
      (format stream "\"~A\"" string)
  )
)

(defun send-arg (stream arg)
"Sends a generic argument to the client over Stream."
  (typecase arg
    (character (princ arg stream))
    (string (send-string stream arg))
    (cons (format stream "(")
	  (loop for element in arg
		for rest on arg do
		(Send-Arg stream element)
		when (rest rest) do (format stream " ")
	  )
	  (format stream ")")
    )
    (pathname (Send-Arg stream (send arg :String-For-Printing)))
    (otherwise (case arg
		 (:Empty-List (format stream "()"))
		 (otherwise (format stream "~A" arg))
	       )
    )
  )
)

(defun send-solicited-command-component (stream &rest args)
"Sends part of a solicited command to the Client over stream."
  (send-arg stream (first args))
  (if (rest args)
      (progn (format stream " ")
	     (apply #'send-solicited-command-component stream (rest args))
      )
      nil
  )
)

(defun send-maybe-bounded-string (stream thing string from to)
"Sends a string that is maybe bounded by From and To."
  (if string
      (let ((real-string (if from (subseq string from to) string)))
	   (Send-Solicited-Command-Component stream thing real-string)
      )
      (Send-Solicited-Command-Component stream thing string)
  )
)


;-------------------------------------------------------------------------------
;;; Command support.
;;; The following are the implementations of the commands for the server.
;-------------------------------------------------------------------------------
;;; The LOGIN Command.
(defmethod process-request ((command (eql :Login)) stream)
"Parses the LOGIN command from the client.  Returns the user is and password."
  (let ((user-id (read-string stream))
	(password (read-string stream))
       )
       (list user-id password)
  )
)

(defmethod process-imap-server-command
	   (stream tag (command (eql :Login)) &rest arglist)
"Logs the user in."
  (ignore stream tag command arglist)
  (destructuring-bind (user-id password) arglist
    (ignore password)
    (setf (symeval-in-instance current-process 'sys:name)
	  (format nil "IMAP server for ~A" user-id)
    )
    (values :Ok (format nil "User ~A logged in." user-id))
  )
)

;-------------------------------------------------------------------------------
;;; The SELECT.VERSION command.

(defmethod process-request ((command (eql :Select.Version)) stream)
"Reads in and selects the version number for the protocol."
  (let ((versions (read-sexpression stream))
	(*read-base* 10.)
       )
       (if (and (consp versions) (equal (length versions) 2))
	   (let ((major (catch-error (read-from-string (first versions)) nil))
		 (minor (catch-error (read-from-string (second versions)) nil))
		)
	        (if (and (numberp major) (numberp minor))
		    (list major minor)
		    nil
		)
	   )
	   nil
       )
  )
)

(defmethod process-imap-server-command
	   (stream tag (command (eql :Select.Version)) &rest arglist)
"Processes the selection of the version.  If the version is not supported
or we couldn't parse the version number then we barf.
"
  (ignore stream tag)
  (destructuring-bind (major minor) arglist
    (if major
        (let ((entry (Find-Version major minor)))
	     (if entry
		 (progn
		   (setq *selected-version* entry)
		   (setq *selected-features*
			 (protocol-version-default-features entry)
		   )
		   (values :Ok
			   (format nil "Selected version (~S ~S)."
				   major minor
			   )
		   )
		 )
		 (values :No (format nil "Unsupported version (~S ~S)"
				     major minor
			     )
		 )
	     )
	)
	(values :No (format nil "Could not parse version."))
    )
  )
)

;-------------------------------------------------------------------------------
;;; The SELECT.FEATURES command.

(defun read-keywords (string start-index)
"Reads a list of keywords from a string.  Start-index is the place we start."
  (if (>= start-index (length string))
      nil
      (multiple-value-bind (keyword stop-index)
	  (let ((*package* (find-package 'keyword)))
	       (read-from-string string nil :Eof :Start start-index)
	  )
	(if (equal :Eof keyword)
	    nil
	    (cons keyword (read-keywords string stop-index))
	)
      )
  )
)

(defmethod process-request ((command (eql :Select.Features)) stream)
"Reads in and returns the features requested."
  (read-keywords (read-line stream) 0)
)

(defmethod process-imap-server-command
	   (stream tag (command (eql :Select.Features)) &rest features)
"Processes the selection of the features.  If any features
are not supported then we barf.
"
  (ignore tag stream)
  (let ((unsupported
	  (set-difference
	    features (protocol-version-supported-features *selected-version*)
	  )
	)
       )
       (if unsupported
	   (values
	     :No (format nil "Unsupported features ~{~A~^ ~}" unsupported)
	   )
	   (progn
	     (setq *selected-features* features)
	     (values :Ok
		     (format nil "Selected Feature~P ~{~A~^, ~}."
			     (length features) features
		     )
	     )
	   )
       )
  )
)

;-------------------------------------------------------------------------------

;;; The NoOp command.
(defmethod process-request ((command (eql :NoOp)) stream)
"Nothing to parse for the NoOp command."
  (ignore stream)
  nil
)

(defmethod process-imap-server-command
	   (stream tag (command (eql :NoOp)) &rest arglist)
"Nothing to do for the NoOp command."
  (ignore stream tag command arglist)
  (values :Ok "Noop received.")
)

;-------------------------------------------------------------------------------

;;; The CHECK command.
(defmethod process-request ((command (eql :Check)) stream)
"No arguments to parse for the CHECK command."
  (ignore stream)
  nil
)

(defmethod process-imap-server-command
	   (stream tag (command (eql :Check)) &rest arglist)
"Checks the current mailbox for new mail."
  (declare (special *current-mailbox*))
  (ignore stream tag command arglist)
  (let ((current-length nil))
       (waiting-for-file-lock
	 (setq current-length (file-length (mail-file-name *current-mailbox*)))
	 (cond ((> current-length (mail-file-file-length *current-mailbox*))
		(new-mail *current-mailbox* stream)
	       )
	       ((< current-length (mail-file-file-length *current-mailbox*))
		(mailbox-expunged *current-mailbox* stream)
	       )
	       (t nil)
	 )
       )
  )
  (Send-Solicited-Command stream tag (number-of-messages-in) :Exists)
  (Send-Solicited-Command stream tag (count-recent-messages *current-mailbox*)
			  :Recent
  )
  (values :Ok "Check received.")
)

(defun new-mail (mailbox stream)
"Parses any new mail that may have arrived in mailbox."
  (ignore stream)
  (parse-mail-file-1 mailbox (file-length (mail-file-name mailbox))
		     (mail-file-format mailbox)
  )
)

(defun mailbox-expunged (mailbox stream)
"Mailbox has been expunged by someone other than us."
  (Send-UnSolicited-Command stream (Number-Of-Messages-In mailbox) :Exists)
  (loop for number from 1 to (Number-Of-Messages-In mailbox) do
	(Send-UnSolicited-Command stream number :Expunge)
  )
  (Send-UnSolicited-Command stream (Number-Of-Messages-In mailbox) :Exists)
)

;-------------------------------------------------------------------------------

;;; The LOGOUT command.
(defmethod process-request ((command (eql :Logout)) stream)
"No arguments for the LOGOUT command."
  (ignore stream)
  nil
)

(defmethod process-imap-server-command
	   (stream tag (command (eql :Logout)) &rest arglist)
"Sends a bye message to the client and saves all of our mail files."
  (declare (special *all-mailboxes*))
  (ignore stream tag command arglist)
  (send-solicited-command stream tag :Bye
    (format nil "~A - TI Explorer IMAP server terminating connection."
	    (send sys:local-host :Fully-Qualified-Name)
    )
  )
  (loop for box in *all-mailboxes* do (write-out-mailbox box))
  (values :Ok "Logout complete."
	  #'(lambda (stream) (send stream :Close) (send current-process :kill))
  )
)

;-------------------------------------------------------------------------------

;;; The FIND command.
(defmethod process-request ((command (eql :Find)) stream)
"Parses a FIND (BBOARDS / MAILBOXES) pattern production from the stream
returning the key and the search pattern.
"
  (let ((key (Read-Atom stream))
	(pattern (read-string stream))
       )
       (list key pattern)
  )
)

(defmethod process-imap-server-command
	   (stream tag (command (eql :Find)) &rest arglist)
"Processes a FIND command from the client.  At present this supports
only Bboards and mailboxes.
"
  (declare (special *current-mailbox*))
  (ignore stream tag command arglist)
  (destructuring-bind (key pattern) arglist
    (process-find-command stream tag (net:intern-as-keyword key) pattern)
  )
)

(defmethod process-find-command (stream tag (key t) pattern)
"Default method called when we don't know what to do with this find key."
  (ignore pattern tag stream)
  (values :Bad (format nil "Unknown find type ~A." key))
)

(defmethod process-find-command (stream tag (key (eql :mailboxes)) pattern)
"Finds all of the mailboxes that match Pattern and sends them back to the client
as solicited Mailboxes messages labeled with Tag.
"
  (let ((all-mailboxes (fs:directory pattern))) ;;;; {!!!!}
       (let ((matches
	       (loop for path in all-mailboxes
		     when (wildcard-match-p path pattern)
		     collect path
	       )
	     )
	    )
	    (loop for match in matches do
		  (Send-Solicited-Command stream tag :Mailbox match)
	    )
	    (values :Ok "Find Mailboxes completed ok.")
       )
  )
)

(defmethod process-find-command (stream tag (key (eql :bboards)) pattern)
"Finds all of the bboards that match Pattern and sends them back to the client
as solicited BBoards messages labeled with Tag.
"
  (let ((all-bboards (fs:directory *bboard-source-path*)))
       (let ((matches
	       (loop for path in all-bboards
		     when (wildcard-match-p path pattern)
		     collect path
	       )
	     )
	    )
	    (loop for match in matches do
		  (Send-Solicited-Command stream tag :Bboard match)
	    )
	    (values :Ok "Find BBoards completed ok.")
       )
  )
)

(defun wildcard-match-p (path pattern)
"Is true if path matches the pattern.  Pattern is specified by the RFC wilcard
characters.
"
  (let ((path-string (send path :String-For-Printing)))
       (fs:Compare-String-Full
	 (fs:parse-search-string pattern '(#\* #\%) 0 0)
	 nil path-string (length path-string) 0
       )
  )
)

;-------------------------------------------------------------------------------

;;; The RENUMBER command.
(defmethod process-request ((command (eql :Renumber)) stream)
"Parses a renumber command."
  (list (Read-Keyword stream) (Read-Keyword stream))
)

(defun get-value-of-field (field-name message)
"Gets a header object for field-name from a message."
  (find-if #'(lambda (head) (equal field-name (send head :Type)))
	   (message-parsed-header message)
  )
)

(defun get-value-string-of-field (field-name message)
"Gets a string or nil for field-name from a message."
  (declare (values string header-field-or-nil))
  (let ((header (get-value-of-field field-name message)))
       (if header
	   (values (let ((string (send header :String-For-Message)))
			(let ((index (position #\space string :Test #'char=)))
			     (if index
				 (nsubstring string (+ 1 index))
				 string
			     )
			)
		   )
		   header
	   )
	   nil
       )
  )
)

(defun set-value-of-field (field-name message to-string)
"Sets a header object for field-name for a message to a new value."
  (let ((existing (get-value-of-field field-name message))
	(new-field (mail:parse-header
		     (string-append (string-capitalize (string field-name))
				    #\: to-string
		     )
		   )
	)
       )
       (setf (message-parsed-header message)
	     (if existing
		 (subst new-field existing (message-parsed-header message))
		 (append (message-parsed-header message) (list new-field))
	     )
       )
  )
)

(defun Safe-Parse-Date (string index)
"Either parses a date out of String or returns Nil."
  (or (catch-error (time:parse-universal-time string index) nil) nil)
)

(defun Field-As-Date (field string index)
"Returns the value of the field as a date if it can."
  (multiple-value-bind (existing found-p) (get field :Parsed-Date)
    (if found-p
	existing
        (let ((date (safe-parse-date string index)))
	     (setf (get field :Parsed-Date) date)
	     date
	)
    )
  )
)

(defun field-as-number (field string index)
"Returns the value in the field parsed as a number if it can be else nil."
  (multiple-value-bind (existing found-p) (get field :Parsed-Number)
    (if found-p
	existing
        (let ((number
		(catch-error (read-from-string string nil :eof :Start index)
			     nil
		)
	      )
	     )
	     (setf (get field :Parsed-Number) (if (numberp number) number nil))
	     (get field :Parsed-Number)
	)
    )
  )
)

(defun field-lessp (field-1 field-2 ordering-type)
"Ordering predicate for header fields according to a specific ordering type."
  (let ((string1
	  (if (stringp field-1) field-1 (send field-1 :String-For-Message))
	)
	(string2
	  (if (stringp field-2) field-2 (send field-2 :String-For-Message))
	)
       )
       (let ((index1 (or (position #\space string1 :Test #'char=) 0))
	     (index2 (or (position #\space string2 :Test #'char=) 0))
	    )
	    (ecase ordering-type
	      (:Date 
	       (< (or (field-as-date field-1 string1 index1) 0)
		  (or (field-as-date field-2 string2 index2) 0)
	       )
	      )
	      (:Numeric
	       (< (or (field-as-date   field-1 string1 index1)
		      (field-as-number field-1 string1 index1)
		      0
		  )
		  (or (field-as-date   field-2 string2 index2)
		      (field-as-number field-2 string2 index2)
		      0
		  )
	       )
	      )
	      (:Alpha
	       (string-lessp string1 string2 :Start1 index1 :Start2 index2)
	      )
	    )
       )
  )
)

(defun sort-message-array (messages field-name ordering-type)
  "Sorts the array Messages according to to field-name and ordering-type."
  (stable-sort messages
	#'(lambda (x y) (field-lessp x y ordering-type))
	:key
	#'(lambda (message)
	    (or (get-value-of-field field-name message) "")
	  )
  )
)

(defun renumber-mailbox (stream tag mailbox field-name ordering-type)
"Renumbers the messages in the current mailbox according to field-name
 and ordering-type.
"
  (let ((old-messages
	  (make-array
	    (array-active-length (mail-file-messages mailbox))
	  )
	)
	(messages (mail-file-messages mailbox))
       )
       (loop for i from 0
	     below (array-active-length messages)
	     do (setf (aref old-messages i) (aref messages i))
       )
       (sort-message-array messages field-name ordering-type)
       (let ((changed
	       (loop for i from 0
		     below (array-active-length messages)
		     when (not (eq (aref old-messages i) (aref messages i)))
		     collect (+ i 1)
	       )
	     )
	    )
	    (if changed
		(progn (Send-Solicited-Command
			 stream tag :Reset
			 ;;; Make this come out as a string without quotes.
			 (intern (yw:colonify-numbers changed) 'keyword)
		       )
		       (setf (mail-file-modified-p mailbox) t)
		       (values :Ok "Renumber complete.  Mailbox changed.")
		)
		(values :Ok "Renumber complete.  Mailbox not changed.")
	    )
       )

  )
)

(defmethod process-imap-server-command
	   (stream tag (command (eql :Renumber)) &rest arglist)
"Renumbers (sorts) the messages in the mailbox."
  (ignore stream tag command)
  (if (feature-enabled-p :Renumber)
      (cond ((not *current-mailbox*) (values :No "No current mailbox."))
	    ((mail-file-read-only-p *current-mailbox*)
	     (values :No "Cannot renumber.  Mailbox is readonly.")
	    )
	    (t (destructuring-bind (field-name ordering-type) arglist
	        (cond ((not (member ordering-type '(:Date :Numeric :Alpha)))
		       (values :No (format nil "~S is not an ordering type."
					   ordering-type
				   )
		       )
		      )
		      (t (renumber-mailbox stream tag *Current-Mailbox*
					   Field-name ordering-type
			 )
		      )
		)
	       )
	    )
      )
      (values
	:No
	"RENUMBER command not available because RENUMBER feature not selected."
      )
  )
)

;-------------------------------------------------------------------------------

;;; The SET.EOL command.
(defmethod process-request ((command (eql :Set.eol)) stream)
"Parses the end of line chars."
  (let ((line (read-line stream))
	(*package* (find-package 'keyword))
	(*read-base* 10.)
	(index 0)
       )
       (loop for (thing stop-index)
	     = (multiple-value-list
		 (read-from-string line nil '_eof_ :Start index)
	       )
	     do (setq index stop-index)
	     until (equal thing '_eof_)
	     collect thing
       )
  )
)

(defmethod process-imap-server-command
	   (stream tag (command (eql :Set.eol)) &rest chars)
"Sets the EOL convention for strings."
  (ignore stream tag command)
  (if (feature-enabled-p :Set.Eol)
      (loop for char in chars
	    when (not (or (member char '(:Cr :Lf))
			  (and (numberp char) (< char 256) (>= char 0))
		      )
		 )
	    do (return :No (format nil "Illegal character value ~S" char))
	    finally (send stream :set-eol-sequence
			  (loop for char in Chars
				collect (case char
					  (:Cr 13.)
					  (:Lf 10.)
					  (otherwise char)
					)
			  )
		    )
	            (return :Ok "EOL sequence set.")
      )
      (values
	:No
	"SET.EOL command not available because SET.EOL feature not selected."
      )
  )
)

;-------------------------------------------------------------------------------

;;; The SEND command.
(defmethod process-request ((command (eql :Send)) stream)
"Parses a format and a message."
  (list (Read-Keyword stream) (Read-String stream))
)

(defmethod send-message ((format (eql :Rfc822)) text)
  "Sends an RFC822 format message."
  (multiple-value-bind (string error-p)
	(catch-error
	  (letf ((#'y-or-n-p #'(lambda (&rest ignore) nil)))
		(let ((string (with-output-to-string (*standard-output*)
				(mail:submit-mail text)
			      )
		      )
		     )
		     (values string nil)
		)
	  )
	  nil
	)
    (cond (error-p (values :No "Error in message delivery."))
	  ((equal "" string) (values :Ok "Message sent."))
	  (t (values
	       :No (format nil "Problems with message sending: ~A" string)
	     )
	  )
    )
  )
)

(defmethod send-message ((format t) text)
  "Default method called when don't understand a message format."
  (ignore text)
  (values :No (format nil "Unknown message format ~A" format))
)

(defmethod process-imap-server-command
	   (stream tag (command (eql :Send)) &rest arglist)
"Sends a message in the specified format."
  (ignore stream tag command)
  (if (feature-enabled-p :Send)
      (Destructuring-bind (format message) arglist
	(send-message format message)
      )
      (values
	:No "Send command not available because SEND feature not selected."
      )
  )
)

;-------------------------------------------------------------------------------

;;; The ADD.MESSAGE command.
(defmethod process-request ((command (eql :Add.Message)) stream)
"Parses a mailbox, a format and a message."
  (list (Read-String stream) (Read-Keyword stream) (Read-String stream))
)

(defmethod add.message ((format (eql :Rfc822)) mailbox text)
  "Add.messages an RFC822 format message."
  (let ((target (Find-Open-Mailbox mailbox)))
       (cond ((and target (mail-file-read-only-p target))
	      (values :No "Cannot ADD.MESSAGE to a readonly mailbox.")
	     )
	     ((not (feature-enabled-p :Add.Message))
	      (values :No "ADD.MESSAGE feature not selected.")
	     )
	     (t ;;; Verify that we can parse the header ok.
	      (with-input-from-string (stream text)
		(loop for (line eof)
		      = (multiple-value-list (send stream :Line-In))
		      when (equal eof line)
		      do (return :No "No end to header found.")
		      when (mail:string-blank-p line)
		      do (append-message-to-mm-file
			   text (time:get-universal-time) mailbox
			 )
			 (return :Ok "Message added.")
		      when (not (mail:header-line-p line))
		      do (return :No
				 (format nil "Bad header line found: ~S" line)
			 )
		)
	      )
	     )
      )
  )
)

(defmethod add.message ((format t) mailbox text)
  "Default method called when don't understand a message format."
  (ignore mailbox text)
  (values :No (format nil "Unknown message format ~A" format))
)

(defmethod process-imap-server-command
	   (stream tag (command (eql :Add.Message)) &rest arglist)
"Adds a message in the specified format to the specified mailbox."
  (ignore stream tag command)
  (if (feature-enabled-p :Add.Message)
      (Destructuring-bind (mailbox format message) arglist
	(add.message format mailbox message)
      )
      (values
	:No
   "ADD.MESSAGE command not available because ADD.MESSAGE feature not selected."
      )
  )
)

;-------------------------------------------------------------------------------

;;; The SELECT command.
(defmethod process-request ((command (eql :Select)) stream)
"Parses and returns the mailbox name from the stream."
  (let ((mailbox-name (read-string stream)))
       (list mailbox-name)
  )
)

(defmethod process-imap-server-command
	   (stream tag (command (eql :Select)) &rest arglist)
"Opens or selects the mailbox in the argument.  Checks for new mail and such."
  (declare (special *current-mailbox*))
  (ignore stream tag command arglist)
  (destructuring-bind (mailbox-name) arglist
    (let ((mailbox (find-or-open-mailbox mailbox-name)))
	 (setq *current-mailbox* mailbox)
	 (send-solicited-command stream tag :Flags yw:*System-Flags*)
	 (Send-Solicited-Command
	   stream tag (number-of-messages-in) :Exists
	   
         )
	 (if (equal *selected-version* *imap2-version*)
	     nil
	     (Send-UnSolicited-Command stream :readwrite)
	 )
	 (send-solicited-command stream tag
				 (count-recent-messages *current-mailbox*)
				 :Recent
         )
    )
    (values :Ok "Select complete.")
  )
)

;-------------------------------------------------------------------------------

;;; The BBOARD command.
(defmethod process-request ((command (eql :BBoard)) stream)
"Parses and returns the mailbox name from the stream."
  (let ((mailbox-name (read-string stream)))
       (list mailbox-name)
  )
)

(defmethod process-imap-server-command
	   (stream tag (command (eql :BBoard)) &rest arglist)
"Opens or selects the bboard in the argument.  Checks for new mail and such."
  (declare (special *current-mailbox*))
  (ignore stream tag command arglist)
  (destructuring-bind (mailbox-name) arglist
    (let ((mailbox (Find-Or-Open-Mailbox
		     mailbox-name (send *bboard-source-path* :New-Type "TXT")
		   )
	  )
	 )
	 (setq *current-mailbox* mailbox)
	 (Process-Imap-Server-Command stream tag :Readonly)
	 (send-solicited-command stream tag :Flags yw:*System-Flags*)
	 (Send-Solicited-Command
	   stream tag (number-of-messages-in) :Exists
	   
         )
	 (if (equal *selected-version* *imap2-version*)
	     nil
	     (Send-UnSolicited-Command stream :readwrite)
	 )
	 (send-solicited-command stream tag
				 (count-recent-messages *current-mailbox*)
				 :Recent
         )
    )
    (values :Ok "BBoard complete.")
  )
)

;-------------------------------------------------------------------------------

;;; The FLAGS command.
(defmethod process-request ((command (eql :Flags)) stream)
"No arguments to parse for the FLAGS command."
  (ignore stream)
  nil
)

(defmethod process-imap-server-command
	   (stream tag (command (eql :Flags)) &rest arglist)
"Returns the mailbox flags."
  (declare (special *current-mailbox*))
  (ignore stream tag command arglist)
  (if *current-mailbox*
      (progn (Send-Solicited-Command
	       stream tag :Flags (mail-file-keywords *current-mailbox*)
	     )
	     (values :Ok "Flags returned.")
      )
      (values :No "No mailbox selected.")
  )
)

;-------------------------------------------------------------------------------

;;; The SET.FLAGS command.
(defmethod process-request ((command (eql :Set.Flags)) stream)
"Returns the set of flags to be set."
  (ignore stream)
  (read-keywords (read-string stream) 0)
)

(defmethod process-imap-server-command
	   (stream tag (command (eql :Set.Flags)) &rest flags)
"Sets the mailbox flags."
  (declare (special *current-mailbox*))
  (ignore stream tag command)
  (if *current-mailbox*
      (let ((new-flags (remove-duplicates (append flags yw:*System-Flags*)))
	    (old-flags (mail-file-keywords *current-mailbox*))
	   )
	   (let ((new-flags-to-store
		   (set-difference new-flags yw:*System-Flags*)
		 )
		)
		(fs:change-file-properties
		  (mail-file-name *current-mailbox*) nil
		  :Mailbox-Keywords new-flags-to-store
                )
	   )
	   ;;; Check all messages to make sure that the client is notified
	   ;;; for any messages that have flags deleted.
	   (let ((deleted (set-difference old-flags new-flags)))
	        (loop for message-number
		      from 1
		      to (Number-Of-Messages-In *current-mailbox*)
		      for message
		          = (The-Message message-number *current-mailbox*)
		      for old-message-flags = (message-flags message)
		      for new-message-flags
		          = (set-difference old-message-flags deleted)
		      when (not (equal (length old-message-flags)
				       (length new-message-flags)
				)
			   )
		      do (setf (message-flags message) new-message-flags)
		         (Say-Flags-Have-Changed-For
			   tag *Current-Mailbox* Message-number message stream
			 )
	        )
	   )
	   (setf (mail-file-keywords *current-mailbox*) new-flags)
           (Send-Solicited-Command stream tag :Flags new-flags)
	   (values :Ok "Flags set.")
      )
      (values :No "No mailbox selected.")
  )
)

;-------------------------------------------------------------------------------

;;; The READONLY command.
(defmethod process-request ((command (eql :ReadOnly)) stream)
"No arguments to parse for the READONLY command."
  (ignore stream)
  nil
)

(defmethod process-imap-server-command
	   (stream tag (command (eql :Readonly)) &rest arglist)
"Marks the current mailbox as readonly."
  (declare (special *current-mailbox*))
  (ignore stream tag command arglist)
  (if *current-mailbox*
      (progn (setf (mail-file-read-only-p *current-mailbox*) t)
	     (Send-Solicited-Command stream tag :Readonly)
	     (values :Ok "Readonly selected.")
      )
      (values :No "No mailbox selected.")
  )
)

;-------------------------------------------------------------------------------

;;; The READWRITE command.
(defmethod process-request ((command (eql :ReadWrite)) stream)
"No arguments to parse for the READWRITE command."
  (ignore stream)
  nil
)

(defmethod process-imap-server-command
	   (stream tag (command (eql :ReadWrite)) &rest arglist)
"Marks the current mailbox as readwrite."
  (declare (special *current-mailbox*))
  (ignore stream tag command arglist)
  (if *current-mailbox*
      (progn (setf (mail-file-read-only-p *current-mailbox*) nil)
	     (Send-Solicited-Command stream tag :Readwrite)
	     (values :Ok "Readwrite selected.")
      )
      (values :No "No mailbox selected.")
  )
)

;-------------------------------------------------------------------------------

;;; The COPY command.
(defmethod process-request ((command (eql :Copy)) stream)
"Parses the sequence and the destination mailbox from the stream."
  (let ((sequence (read-sequence stream))
	(mailbox-name (read-string stream))
       )
       (list sequence mailbox-name)
  )
)

(defmethod process-imap-server-command
	   (stream tag (command (eql :Copy)) &rest arglist)
"Processes a copy command, moving the message to the appropriate mailbox."
  (declare (special *current-mailbox*))
  (ignore stream tag)
  (destructuring-bind (sequence mailbox-name) arglist
    (if *current-mailbox*
	(let ((target (Find-Open-Mailbox mailbox-name)))
	     (if (and target (mail-file-read-only-p target))
		 (values :No "Cannot copy to a readonly mailbox.")
		 (waiting-for-file-lock
		   (with-open-file (ostream mailbox-name
					    :Direction :Output
					    :If-Exists :Append
					    :If-Does-Not-Exist :Create
				   )
		     (loop for message-number in sequence
			   for message
			       = (The-Message message-number *current-mailbox*)
			   do (format ostream "~A"
				      (message-whole-message message)
			      )
			      (if (equal *Selected-Version* *imap2-version*)
				  nil
				  (Send-Solicited-Command
				    stream tag :Copy message-number
				  )
			      )
			      (if (Auto.Set.Seen-P)
				  (Set-Flag *current-mailbox* message :\\Seen t)
				  nil
			      )
		     )
		   )
		 )
	     )
	)
	(values :No "No mailbox selected.")
    )
  )
  (values :Ok "Copy completed.")
)

;-------------------------------------------------------------------------------

;;; The SUPPORTED.VERSIONS command
(defmethod process-request ((command (eql :Supported.Versions)) stream)
"No arguments to this command."
  (ignore stream)
  nil
)

(defmethod process-imap-server-command
	   (stream tag (command (eql :Supported.Versions)) &rest arglist)
"Returns the set of supported versions to the client."
  (declare (special *current-mailbox*))
  (ignore arglist)
  (Send-Solicited-Command stream tag command
    (loop for version in *imap-server-supported-versions*
	  collect `(,(protocol-version-major version)
		    ,(protocol-version-minor version)
		    ,@(loop for feature
			    in (protocol-version-supported-features version)
			    when (not (~command-p feature))
			    collect feature
		      )
		    )
    )
  )
  (values :Ok "Supported Versions command completed ok.")
)

;-------------------------------------------------------------------------------

;;; The EXPUNGE command.
(defmethod process-request ((command (eql :Expunge)) stream)
"No arguments for the expunge command."
  (ignore stream)
  nil
)

(defmethod process-imap-server-command
	   (stream tag (command (eql :Expunge)) &rest arglist)
"Executes the EXPUNGE command, rearranging the mailbox as appropriate and
notifying the client about the changes.
"
  (declare (special *current-mailbox*))
  (ignore stream tag arglist)
  (if *current-mailbox*
      (if (mail-file-read-only-p *current-mailbox*)
	  (values :No "Mailbox is readonly.")
	  (with-write-lock (*current-mailbox*)
	    (let ((write-index 0)
		  (messages (mail-file-messages *current-mailbox*))
		  (deleted nil)
		  (number-deleted 0)
		 )
		 (Send-Solicited-Command
		   stream tag (Number-Of-Messages-In *current-mailbox*) :Exists
		 )
		 (loop for current-index
		       from 0
		       below (Number-Of-Messages-In *current-mailbox*)
		       for message-number = (+ 1 current-index)
		       for message
		           = (The-Message message-number *current-mailbox*)
		       do (if (deleted-p message)
			      (progn (push message-number deleted)
				     (setq number-deleted (+ 1 number-deleted))
			      )
			      (progn (setf (aref messages write-index)
					   (aref messages current-index)
				     )
				     (setq write-index (+ 1 write-index))
			      )
			  )
		 )
		 (setf (mail-file-modified-p *current-mailbox*) t)
		 (setf (fill-pointer messages)
		       (- (fill-pointer messages) number-deleted)
		 )
		 (if (> number-deleted 0) (write-out-mailbox *current-mailbox*))
		 (loop for number in (nreverse deleted) do ;;; {!!!!}
		       (Send-Solicited-Command stream tag number :Expunge)
		 )
		 (Send-Solicited-Command
		   stream tag (Number-Of-Messages-In *current-mailbox*) :Exists
		 )
	    )
	    (values :Ok "Expunge complete.")
	  )
      )
      (values :No "Cannot expunge.  No mailbox selected.")
  )
)


;-------------------------------------------------------------------------------

;;; The default command.
(defmethod process-request ((command t) stream)
"The default command parser.  We must have read some command that we didn't
understand.
"
  (ignore stream)
  (values nil :!!!!!!!!!!!!!!!)
)

(defmethod process-imap-server-command
	   (stream tag command &rest arglist)
"The default command processor.  Tells the client about the BAD."
  (ignore stream tag arglist)
  (values :Bad (format nil "Unrecognised command ~S" command))
)