;;;-*- Mode:LISP; Package:ZWEI-*-;;; Mail server for the local file system;;; ** (c) Copyright 1981 Massachusetts Institute of Technology **;;; ** (c) Enhancements copyright 1981 Symbolics, Inc. **;;; For now only allow mail from one place at a time.(DEFVAR *MAIL-SERVER-LOCK* NIL)(DEFUN MAIL-SERVER (&AUX LOCK CONN STREAM (USER-ID USER-ID))  (SETQ LOCK (LOCF *MAIL-SERVER-LOCK*))  (CATCH-ERROR    (UNWIND-PROTECT      (PROG TOP ()‰    (AND (EQUAL USER-ID "") (SETQ USER-ID "Mail-server"))‰    (PROCESS-LOCK LOCK)‰    (SETQ CONN (CHAOS:LISTEN "MAIL"))‰    (CHAOS:ACCEPT CONN)‰    (FUNCALL TV:WHO-LINE-FILE-STATE-SHEET ':ADD-SERVER CONN "MAIL")‰    (SETQ STREAM (CHAOS:STREAM CONN))‰    (LET* ((RECIPIENTS (READ-MAIL-RECIPIENTS STREAM))‰‰   (TEXT (GET-MAIL-TEXT STREAM)))‰      (DOLIST (RECIPIENT RECIPIENTS)‰‰(LET ((PATHNAME (FS:MAKE-PATHNAME ':HOST "local"‰‰‰‰‰‰  ':DIRECTORY (STRING-APPEND #/> RECIPIENT)‰‰‰‰‰‰  ':NAME "MAIL"‰‰‰‰‰‰  ':TYPE "TEXT"‰‰‰‰‰‰  ':VERSION ':NEWEST)))‰‰(WITH-OPEN-FILE (OUTFILE PATHNAME '(:OUT :NOERROR))‰‰  (COND ((STRINGP OUTFILE)‰‰‰ (FORMAT STREAM "-Unexpected error for ~A: ~A~%" RECIPIENT OUTFILE)‰‰‰ (FUNCALL STREAM ':FORCE-OUTPUT)‰‰‰ (RETURN-FROM TOP)))‰‰  ;; This always appends new mail.  ZMail knows how to reverse it after all.‰‰  (WITH-OPEN-FILE (INFILE PATHNAME '(:IN :NOERROR))‰‰    (IF (STRINGP INFILE)‰‰‰(MULTIPLE-VALUE-BIND (ERR NIL MSG)‰‰‰    (FS:FILE-PROCESS-ERROR INFILE PATHNAME NIL T)‰‰‰  (IF (STRING-EQUAL ERR "FNF")‰‰‰      ;; If this is the first file, make there only be one copy‰‰‰      (FS:CHANGE-FILE-PROPERTIES PATHNAME NIL‰‰‰‰‰‰‰ ':GENERATION-RETENTION-COUNT 1)‰‰‰      (FORMAT STREAM "-Unexpected error for ~A: ~A~%" RECIPIENT MSG)‰‰‰      (FUNCALL STREAM ':FORCE-OUTPUT)‰‰‰      (RETURN-FROM TOP)))‰‰‰(STREAM-COPY-UNTIL-EOF INFILE OUTFILE)))‰‰  (FUNCALL OUTFILE ':STRING-OUT TEXT)‰‰  (FUNCALL OUTFILE ':LINE-OUT "")))))‰    (FORMAT STREAM "+Message sent successfully.~%")‰    (FUNCALL STREAM ':FORCE-OUTPUT)‰    (FUNCALL STREAM ':FINISH)‰    (FUNCALL STREAM ':CLOSE))      (AND CONN (CHAOS:REMOVE-CONN CONN))      (PROCESS-UNLOCK LOCK))    NIL))(DEFUN READ-MAIL-RECIPIENTS (STREAM)  (DO ((LINE)       (RECIPIENTS NIL)       (AT-POS))      (NIL)    (SETQ LINE (FUNCALL STREAM ':LINE-IN))    (AND (EQUAL LINE "") (RETURN (NREVERSE RECIPIENTS)))    (AND (SETQ AT-POS (STRING-SEARCH-CHAR #/@ LINE))‰ (= (CHAOS:ADDRESS-PARSE (SUBSTRING LINE (1+ AT-POS))) CHAOS:MY-ADDRESS)‰ (SETQ LINE (SUBSTRING LINE 0 AT-POS)))    (IF (NOT (PROBEF (FS:MAKE-PATHNAME ':HOST "local"‰‰‰‰       ':DIRECTORY ">"‰‰‰‰       ':NAME LINE‰‰‰‰       ':TYPE ':DIRECTORY‰‰‰‰       ':VERSION 1)))‰(FORMAT STREAM "-Unknown user ~A.~%" LINE)‰(PUSH LINE RECIPIENTS)‰(FORMAT STREAM "+Recipient name ~A ok.~%" LINE))    (FUNCALL STREAM ':FORCE-OUTPUT)))(DEFUN GET-MAIL-TEXT (STREAM)  (WITH-OUTPUT-TO-STRING (SSTREAM)    (STREAM-COPY-UNTIL-EOF STREAM SSTREAM)    (FUNCALL SSTREAM ':FRESH-LINE)))(ADD-INITIALIZATION "MAIL"                    '(PROCESS-RUN-TEMPORARY-FUNCTION "MAIL Server" 'MAIL-SERVER)                    NIL                    'CHAOS:SERVER-ALIST)