;;; -*- Mode:LISP; Package:SERIAL; Base:8; Fonts:(CPTFONT TR12I) -*-

;1;;This file contains the serial server program.*

(defvar remotely-readable-directories '("Dulcey" "remote-info" "remote-patch"
					"remote-temporary")
  "Directories which can be used as sources for file transfers.")
(defvar remotely-writeable-directories '("remote-temporary" "Dulcey")
  "Directories which can be used as destinations for file transfers.")
(defvar remote-mail-reader-users '("Dulcey" "Naha" "Dexter")
  "Users who can read their mail from the server.")
(defvar server-stream nil "The serial stream in use by the server.")
(defvar server-transfer-flavor 'lmodem-connection "Flavor of file transfer to be used.")
(sstatus nofeature real-serial-server)

(defun remote-serial-server ()
  (let* ((server-stream (make-server-stream))
	 (standard-input server-stream)
	 (standard-output server-stream)
	 (query-io server-stream))
    (do-forever (serial-server-top-level))))

(defun enable-serial-server ()
  (process-run-function "Serial server" 'remote-serial-server))

(defun serial-server-top-level (&aux (server-transfer-flavor 'lmodem-connection))
  #+real-serial-server (send standard-output ':reset)
  #+real-serial-server (send standard-output ':put ':data-terminal-ready T)
  #+real-serial-server (dotimes (dummy 10.)
			 (send standard-input ':tyi))
  (format standard-output "~%~%LMI serial server~%~%")
  (let ((user-id (prompt-and-read ':string "User name: ")))
    (do-forever
      (format standard-output "~%Operation? ")
      (let ((char (char-upcase (tyi))))
	(selectq char
	  ((#Return #Control-L) nil)
	  (#B (server-send-bug))
	  (#D (server-list-directory))
	  ((#H #? #Control-_) (server-help))
	  (#M (server-send-mail))
	  (#P (server-select-file-protocol))
	  (#Q (when (y-or-n-p "Do you really want to quit? ")
		 (return nil)))
	  (#R (server-transmit-file))
	  (#T (server-receive-file))
	  (#V (server-view-mail))
	  (t (format standard-output "~%Unknown operation.  Type H for help.")))))
    #+real-serial-server (send standard-output ':eval-inside-yourself
			       '(si:serial-write-command (logand 7775 si:uart-command)))
    ))

#+real-serial-server
 (defun make-server-stream ()
   (make-instance 'si:serial-stream
		  ':baud 1200.
		  ':number-of-data-bits 8.
		  ':number-of-stop-bits 1
		  ':parity nil
		  ':ascii-characters nil))
#-real-serial-server (defun make-server-stream () terminal-io)

(defun server-help ()
  (format standard-output "

You are using the LMI serial server.
Commands:

B	Send a bug report
D	List a directory
H	Print this message
M	Send mail
P	Select file transfer protocol
Q	Quit
R	Receive a file (file goes from the server to you)
T	Transmit a file (file goes from you to the server)
V	View your mail

"))

(defun server-list-directory ()
  (let ((directory (prompt-and-read
		     `(:pathname :defaults ,(send (fs:user-homedir "fs") ':new-pathname
									 ':name ':wild
									 ':type ':wild
									 ':version ':wild))
		"~%~%Directory: ")))
    (terpri standard-output)
    (cond ((server-verify-file-for-transmit directory)
	     (condition-case ()
		 (let ((dir-list (fs:directory-list directory)))
		   (mapc #'(lambda (path) (zwei:default-list-one-file path standard-output))
			 dir-list))
	       (fs:file-lookup-error (format standard-output
					     "The directory ~A does not exist.~%"
					     directory))))
	  (t (format standard-output
		     "The directory ~A is not listable remotely.~%" directory))))
  nil)

;1;; Note that the names of the next two functions are egocentric, but the command names are*
;1;; defined from the point of view of the user.*

(defun server-transmit-file ()
  (let ((file (prompt-and-read `(:pathname :defaults ,(fs:user-homedir))
			       "~%~%File to receive: ")))
    (cond ((not (server-verify-file-for-transmit file))
	   (format standard-output "Remote access to file ~A is not permitted.~%" file))
	  (t (condition-case ()
		 (send (make-instance server-transfer-flavor ':modem-stream server-stream)
		       ':send-file file)
	       (fs:file-lookup-error (format standard-output
					     "The file ~A does not exist.~%" file)))))))

(defun server-receive-file ()
  (let ((file (prompt-and-read `(:pathname :defaults ,(fs:user-homedir))
			       "~%~%File to transmit: ")))
    (cond ((not (server-verify-file-for-receive file))
	   (format standard-output "Remote access to file ~A is not permitted.~%" file))
	  (t (send (make-instance server-transfer-flavor ':modem-stream server-stream)
		   ':get-file file)))))

(defun server-verify-file-for-transmit (path)
  (member (send path ':directory) remotely-readable-directories))

(defun server-verify-file-for-receive (path)
  (member (send path ':directory) remotely-writeable-directories))

(defun server-verify-mail-reader (name)
  (member name remote-mail-reader-users))

(defunp server-view-mail ()
  (when (not (server-verify-mail-reader user-id))
    (format standard-output "~%Sorry, you do not have remote mail reading privileges.~%")
    (return nil))
  (let* ((home-dir (fs:user-homedir "FS"))
	 (out-message-count 0)
	 (mail-file (send home-dir ':new-pathname ':name "mail" ':type "text"
						  ':version ':newest))
	 (old-mail-file (send mail-file ':new-pathname ':name "_serial_server_mail_input_"
						       ':type "_temporary_file_"))
	 (out-file (send old-mail-file ':new-pathname ':name "_serial_server_mail_output_"))
	 (rmail-file (send mail-file ':new-pathname ':name user-id ':type "rmail")))
    (cond ((not (probef mail-file))
	   (format standard-output "~%~%No new mail.~%"))
	  (t (terpri standard-output)
	     (terpri standard-output)
	     (renamef mail-file old-mail-file)
	     (with-open-file (mail-out out-file ':direction ':output)
	       (with-open-file (mail-in old-mail-file ':direction ':input)
		 (loop while (loop with line-list = nil
				   with line
				   with end-flag
				   do (multiple-value (line end-flag)
					(send mail-in ':line-in))
				   until end-flag
				   while line
				   until (string-equal line "")
				   do (send standard-output ':line-out line)
				      (push line line-list)
				   finally (when (y-or-n-p "Save this message? ")
					     (loop for out-line in (nreverse line-list)
						   do (send mail-out ':line-out out-line))
					     (incf out-message-count))
					   (terpri standard-output)
					   (terpri standard-output)
					   (send mail-out ':line-out "")
					   (return (and (not end-flag) line))))
		 (deletef mail-in))
	       (when (and (not (zerop out-message-count))
			  (probef rmail-file))
		 (format standard-output "Copying old saved messages...")
		 (with-open-file (rmail-in rmail-file ':direction ':input)
		   (fs:stream-copy-until-eof rmail-in mail-out))
		 (format standard-output " done.~%")))
	     (renamef out-file rmail-file)))))