;;; -*- Mode:LISP; Package:ZWEI; Base:10; Readtable:CL -*-

;;;MFHOST2

;;;Like MFHOST, this file is for system-dependent ZMail extensions
;;;and support code.  Unlike MFHOST, this file is in CommonLISP, the
;;;syntax of "real" LISP programmers.

(defun make-unix-zmail-init-file (username unix-host login-dir &aux realhost)
  "This function makes mail initialization files for a ZMail user
 on a LISP machine who also uses a Unix mail server host.
\
For example, I am user GJC, my LISP home directory is \"LAM3:GJC;\", and I
 want to get my mail from the Unix host ANGEL; so I would execute:
\
  (make-unix-zmail-init-file 'gjc 'angel \"lam3:gjc;\")
\
This creates two files, one in the LISP home directory called 'ZMAIL.INIT',
 and one in the Unix home directory called '<user>.bb'.
\
Returns two values, the pathnames of the two ZMail initialization files."
  ;;
  (declare(values zmail-pathname mailfile-pathname))
  ;;
  (setq realhost (si:parse-host unix-host))
  (unless (eq (send realhost :system-type) :unix)
    (cerror "Proceed anyway, hoping for the best"
	    "The host ~s is not type :UNIX - it is a ~s system"
	    unix-host (send realhost :system-type)))
  (multiple-value-bind (real-username fullname home-directory-string error-msg)
      (lookup-user-etc-passwd username unix-host)
    (unless (and real-username fullname home-directory-string)
      (warn "Unable to make your Unix-ZMail-INIT-file~@[: ~a~]." error-msg)
      (return-from make-unix-zmail-init-file nil))
    (let* ((realhome (fs:parse-pathname (string-append home-directory-string "/")
					realhost))
	   (mailfile-pathname (fs:merge-pathnames "mail.bb" realhome))
	   (zmail-pathname (send (fs:parse-pathname login-dir)
				 :new-pathname
				 :name "ZMAIL"
				 :type "INIT"
				 :version :highest))
	   (spool-dir (fs:parse-pathname "/usr/spool/mail/" realhost))
	   (spool-file (fs:merge-pathnames 
			 (fs:parse-pathname real-username realhost)
			 spool-dir)))
      (declare(ignore unix-p))
      ;;So long as there isn't one already...
      (and (or (null (probe-file zmail-pathname))
	       ;;or the caller says it's ok...
	       (yes-or-no-p "~%The ZMail initialization file ~s already exists...~
                             ~&  is it OK to overwrite it?"
			    zmail-pathname))
	   ;;Write out ZMail .init file
	   (with-open-file (stream zmail-pathname :direction :output)
	     (format t "~%Writing out ~s..." zmail-pathname)
	     (let ((*readtable* (si:find-readtable-named "Common-Lisp"))
		   (*package* (find-package "ZWEI"))
		   (*print-base* 10.)
		   (*read-base*  10.))
	       (format stream ";;-*-Mode:LISP;Package:~A;Base:~10r;ReadTable:~A-*-~%"
		       (package-name *package*)
		       *read-base*
		       (si:rdtbl-short-name si:common-lisp-readtable))
	       (format stream "~&~
                      ~%(login-setq *zmail-startup-file-name* ~S)~
                      ~2%(login-setq *from-user-id* ~S)~
                      ~2%(login-setq *from-host* (si:parse-host ~S))~
                      ~2%(login-setq fs:user-personal-name-first-name-first ~S)~
                      ~2%(login-setq zwei:*zmail-usual-mail-file-directory* ~S)~
                      ~2%(login-setq zwei:*zmail-homedir-real-new-mail-filename* ~S)~2%"
		       (send mailfile-pathname :string-for-printing)
		       real-username
		       (send realhost :name)
		       fullname
		       (send realhome :string-for-printing)
		       (send spool-file :string-for-printing)))))
      ;;So long as there isn't one already...
      (and (or (null (probe-file mailfile-pathname))
	       ;;or the caller says it's ok...
	       (yes-or-no-p "~%The mail file ~s already exists...~
                             ~&  is it OK to overwrite it?"
			    mailfile-pathname))
	   ;;write Babyl file in user's Unix home directory.
	   (with-open-file (stream mailfile-pathname :direction :output)
	     (format t "~%Writing out ~s..." mailfile-pathname)
	     (format stream "Babyl Options:~
                        ~%Append:1~
                        ~%Version:5~
                        ~%Mail: ~A~
                        ~%Owner:~A~
                        ~%Summary-window-format: T~
                        ~%"
		     (send spool-file :string-for-printing)
		     real-username)))
      ;;Return the pathnames we wrote out
      (values zmail-pathname mailfile-pathname))))

(defun lookup-user-etc-passwd (username host &optional (passwd-file "/etc/passwd"))
  "Look up password file entry for USERNAME on Unix HOST.
Returns 4 values:
  UNAME    - the actual username found.
  FULLNAME - the user's fullname entry.
  DIR      - the user's home directory entry.
  ERROR-STRING, if non-NIL, is a string indicating the lookup error."
  (declare(values uname fullname dir error-string))
  (ctypecase username
    (string)
    (symbol (setq username (string username))))
  (multiple-value-bind(uname fullname dir error-string)
      (with-open-file (stream (fs:parse-pathname passwd-file host))
	(do ((st))
	    ((cond
	       ((null (setq st (read-line stream nil)))
		(format t "~&End-of-file in Unix password file.")
		(return (values nil nil nil
				(format nil  "Entry for ~s not found" username))))
	       ((not (string-equal username
				   (substring st 0 (string-search ":" st))))
		nil)
	       ((y-or-n-p "~&Is this your Unix username entry? -->'~A'~% ...?" st)
		(return (parse-user-etc-passwd st)))))))
    (values uname fullname dir error-string)))

(defun parse-user-etc-passwd (st)
  ;; username:password:uic:gid:Full Name:directory:shell
  (let ((n (string-search ":" st))
	(uname)(fullname)(dir))
    (setq uname (substring st 0 n))
    (setq n (string-search ":" st (1+ n)))	; pass
    (setq n (string-search ":" st (1+ n)))	; uid
    (setq n (string-search ":" st (1+ n)))	; gid
    (setq fullname (substring st (1+ n)
			      (setq n (string-search ":" st (1+ n)))))
    (if (string-search "," fullname)
	(setq fullname (substring fullname 0 (string-search "," fullname))))
    (setq dir (substring st (1+ n) (string-search ":" st (1+ n))))
    (values uname fullname dir)))