;; -*- Mode: Lisp; Base: 8.; Package: Hacks -*-

;; Alarm system for Lispms.  
;; Written by Dave Andre in August 1981.
;; Additional features added by Howard Trachtman, 1982.

						;future plans:
  ;;win more when error occurs (user can restart alarm)
  ;; Allow user to delete alarms easily.

  ;; provide much more user flexibility in things to be searched for.
  ;; allow memos which are not to be gotten until very far in the
  ;; future be mailed.   

  ;; implement something like a PCAL, this may have be better suited
  ;; for zwei see sys:zmail;calender

  ;; maybe a mouse interface, but I don't know for what.

  ;; provide more flexibility in how often to search for something.
  ;; impliment some kind of mini-scheduler (or use the real one)

  ;look for lisp machines which are free (or not so free) and have a particular band on them.

  ;;   Can we have clock driven interrupts?
  ;; Provide some of the functionality of process-run-function

  ;;Merge mail and file checks.
  
  ;;usage from other machines, like notify when a lispm frees up.

  ;;force checking of particular alarms
  ;;look at bradst's stuff.

  ;(tv:notify-with-query)

  ;save up notifications.  use some kind of alarm-notify function.
 ;periodic notifications.

;; Make alarm go off when the status of somebody logged in somewhere changes.

;; Make alarm go off if the dover status changes.

  ;; I had some other ideas, but forgot them.  Suggestions welcome.


  ;;Documentation

;; The system is driven by the symbols on ALARM-LIST.
;; Any symbol on the list should have the following properties defined as functions:
;;
;;  CHECK:  This function is called periodically and should return a boolean which
;;  states whether an alarm condition exists.
;;  
;;  NOTIFY &optional dont-notify-p:  This function is called if the CHECK function
;;  has notified the alarm process that an alarm condition exists.  This function
;;  should update its knowledge to state that the user has been notified, and unless
;;  dont-notify-p is true, should notify the user of the occurance.  If it can also
;;  be determined that an alarm condition will no longer exist, this function may
;;  remove its associated alarm from ALARM-LIST.
;;
;;  RESET:  This function should reset the alarm's knowledge to its initial state.
;;  For example, the MAIL alarm checks for mail to various people.  This function
;;  would then remove any people from the alarm's knowledge.
;;
;;  ADD-ALARM new-condition:  This function's argument uniquely specifies a condition
;;  to check for.  Calling this function adds this condition to the alarm's knowledge.


(DEFVAR ALARM-LIST NIL "A list of symbols which represnt which things we might ALARM about.")
(DEFVAR ALARM-LIST-LOCK NIL "Used internally to lock out the alarm process while we
are hacking up the alarm database.")

(DEFVAR ALARM-INHIBIT-NOTIFICATION-LIST NIL "This is a list of alarms which should not
signal a notification the next time they are checked.")

(DEFUN SET-ALARM-INHIBIT-NOTIFY (ALARM)
  "Inhibit an alarm from bothering the user the next time that event occurs."
  (WITHOUT-INTERRUPTS
    (OR (MEMQ ALARM ALARM-INHIBIT-NOTIFICATION-LIST)
	(PUSH ALARM ALARM-INHIBIT-NOTIFICATION-LIST))))


(DEFVAR ALARM-SLEEP-TIME 7200. "The alarm process sleeps for this amount of time
(in 60ths of a second) between checking ALARM-LIST. Defaults to two minutes.")

(DEFVAR ALARM-PROCESS NIL "This variable keeps track of the actual alarm process.
 We normally have a lower priority than other processes.")

(DEFVAR ALARM-PROCESS-PRIORITY -1 "The priority of the alarm process.")

;;; Entry functions

(DEFUN ADD-ALARM (ALARM)
  "Add a new alarm to the list of alarms.  Don't call this yourself!"
  (CHECK-ARG ALARM
	     (GET ALARM 'CHECK)
	     "an alarm")
  (ACTIVATE-ALARM-PROCESS)
  (UNWIND-PROTECT
    (PROGN (PROCESS-LOCK (LOCF ALARM-LIST-LOCK) NIL "Alarm Lock")
	   (COND ((NOT (MEMQ ALARM ALARM-LIST))
		  (PUSH ALARM ALARM-LIST))))
    (%STORE-CONDITIONAL (LOCF ALARM-LIST-LOCK) CURRENT-PROCESS NIL)))

(DEFUN DELETE-ALARM (ALARM)
  "Remove an alarm from the list of alarms.  Don't call this yourself!"
  (UNWIND-PROTECT
    (PROGN (PROCESS-LOCK (LOCF ALARM-LIST-LOCK) NIL "Alarm Lock")
	   (FUNCALL (GET ALARM 'RESET))
	   (SETQ ALARM-LIST (DELQ ALARM ALARM-LIST)))
    (%STORE-CONDITIONAL (LOCF ALARM-LIST-LOCK) CURRENT-PROCESS NIL)))

(DEFUN ACTIVATE-ALARM-PROCESS ()
  "Activate an alarm in the list of alarms.  Don't call this yourself!"
  (OR ALARM-PROCESS
      (SETQ ALARM-PROCESS
	    (MAKE-PROCESS "Alarm Background" ':PRIORITY ALARM-PROCESS-PRIORITY)))
  (COND ((NULL (SI:PROCESS-RUN-REASONS ALARM-PROCESS))
	 (SEND ALARM-PROCESS :PRESET 'ALARM-BACKGROUND-TOP-LEVEL)
	 (PROCESS-ENABLE ALARM-PROCESS))))

(DEFUN DEACTIVATE-ALARM-PROCESS (&OPTIONAL RESET-ALARMS)
  "Deactivate an alarm in the list of alarms.  Don't call this yourself!"
  (COND ((NOT (NULL ALARM-PROCESS))
	 (IF (EQ CURRENT-PROCESS ALARM-PROCESS)
	     (PROCESS-RUN-FUNCTION "Alarm Temp" 'DEACTIVATE-ALARM-PROCESS)
	     (COND (RESET-ALARMS
		    (SETQ ALARM-INHIBIT-NOTIFICATION-LIST NIL)
		    (DOLIST (ALARM ALARM-LIST)
		      (FUNCALL (GET ALARM 'RESET)))
		    (SETQ ALARM-LIST NIL)))
	     (FUNCALL ALARM-PROCESS ':KILL)))))

(ADD-INITIALIZATION "Deactivate Alarms"
		    '(DEACTIVATE-ALARM-PROCESS T)
		    '(LOGOUT))

;;; Internal workings.

  ;better way?
(DEFMACRO DELETE-ELEMENT (N ELEMENT)
  `(SETF (NTHCDR ,N ,ELEMENT) (CDR (NTHCDR ,N ,ELEMENT))))

(DEFVAR *CURRENT-ALARM* NIL "Internal variable used from the alarm presently being checked.")

(DEFUN ALARM-BACKGROUND-TOP-LEVEL ()
  "Top level function of the alarm background process.  Is smart about internal errors."
  (ERROR-RESTART-LOOP ((SYS:ABORT ERROR) "Return to top level of ALARM-BACKGROUND.")
    (DO ((NOTIFICATION-QUEUE NIL NIL)) (NIL)
      (LET ((USER-ID USER-ID) VAL ERR)
	(AND (EQUAL USER-ID "")
	     (SETQ USER-ID "Alarm-Background"))
	(UNWIND-PROTECT
	  (PROGN (PROCESS-LOCK (LOCF ALARM-LIST-LOCK) NIL "Alarm Lock")
		 (CONDITION-BIND ((ERROR 'ALARM-CONDITION-HANDLER))
		   (DOLIST (*CURRENT-ALARM* ALARM-LIST)
		     (MULTIPLE-VALUE (VAL ERR)
		       (*CATCH 'ALARM (FUNCALL (GET *CURRENT-ALARM* 'CHECK))))
		     (COND (ERR (SETQ ALARM-LIST
				      (DELQ *CURRENT-ALARM* ALARM-LIST))
				(FUNCALL (GET *CURRENT-ALARM* 'RESET)))
			   (VAL (PUSH *CURRENT-ALARM* NOTIFICATION-QUEUE))))))
	  (%STORE-CONDITIONAL (LOCF ALARM-LIST-LOCK) CURRENT-PROCESS NIL))
	(DOLIST (ALARM (NREVERSE NOTIFICATION-QUEUE))
	  (COND ((MEMQ ALARM ALARM-INHIBIT-NOTIFICATION-LIST)
		 (SETQ ALARM-INHIBIT-NOTIFICATION-LIST
		       (DELQ ALARM ALARM-INHIBIT-NOTIFICATION-LIST))
		 (FUNCALL (GET ALARM 'NOTIFY) T))
		(T (FUNCALL (GET ALARM 'NOTIFY)))))
	(PROCESS-SLEEP ALARM-SLEEP-TIME "Alarm Wait")
	(OR ALARM-LIST (DEACTIVATE-ALARM-PROCESS))))))

(DEFUN ALARM-CONDITION-HANDLER (CONDITION)
  "Notify the user of an error while processing an alarm."
  (TV:NOTIFY NIL
	     (FORMAT NIL "Error in the alarm process while checking ~A alarms.
Removing ~:*~A from the active alarm list.
The error was: ~A" *CURRENT-ALARM* CONDITION))
  (*THROW 'ALARM NIL))

;;; Alarm definitions.

;; File checks.  Notifies whenever the INFO of a file on this list changes.
(DEFVAR FILES-TO-BE-MONITORED NIL "List of files to check for creation date changes.")
(DEFVAR FILES-TO-BE-MONITORED-PREVIOUS-PLIST NIL "Plist of info about FILES-TO-BE-MONITERED.")
(DEFVAR FILES-TO-BE-NOTIFIED "List of files which for we will notify when they change.")

(DEFUN PLIST-INFO (PLIST)
  "Returns a cons which returns useful info about the creation date of a file."
  (CONS (GET PLIST ':TRUENAME) (GET PLIST ':CREATION-DATE)))

(DEFUN (FILE CHECK) ()
  (LET ((PLIST (FS:MULTIPLE-FILE-PLISTS FILES-TO-BE-MONITORED)))
    (DOLIST (ENTRY PLIST)
      (COND ((NOT (EQUAL (PLIST-INFO (ASSOC (CAR ENTRY) FILES-TO-BE-MONITORED-PREVIOUS-PLIST))
			 (PLIST-INFO ENTRY)))
	     (PUSH (LIST (CAR ENTRY) (GET ENTRY ':CREATION-DATE))
		   FILES-TO-BE-NOTIFIED))))
    (SETQ FILES-TO-BE-MONITORED-PREVIOUS-PLIST PLIST)
    FILES-TO-BE-NOTIFIED))

(DEFUN (FILE NOTIFY) (&OPTIONAL DONT-NOTIFY-P)
  (OR DONT-NOTIFY-P
      (DOLIST (ENTRY FILES-TO-BE-NOTIFIED)
	(LEXPR-FUNCALL 'TV:NOTIFY NIL "File ~A modified at ~\TIME\" ENTRY)))
  (SETQ FILES-TO-BE-NOTIFIED NIL))

(DEFUN (FILE PRINT) (STREAM &AUX (N 0))
  (FORMAT STREAM "~&FILE Alarms:")
  (IF (NULL FILES-TO-BE-MONITORED)
      (FORMAT STREAM "   There are no files being monitored.~%")
    (DOLIST (FILE FILES-TO-BE-MONITORED)
      (FORMAT STREAM "~%[~A] The file ~A is being monitored for changes." (INCF N) FILE))))

(DEFUN (FILE REMOVE-ALARM) (N)
  (WITHOUT-INTERRUPTS
    (DELETE-ELEMENT N FILES-TO-BE-MONITORED))) 

(DEFUN (FILE RESET) ()
  (SETQ FILES-TO-BE-MONITORED NIL
	FILES-TO-BE-MONITORED-PREVIOUS-PLIST NIL
	FILES-TO-BE-NOTIFIED NIL))

(DEFUN (FILE ADD-ALARM) (ALARM)
  (SETQ ALARM (FS:MERGE-PATHNAME-DEFAULTS ALARM))
  (OR (MEMQ ALARM FILES-TO-BE-MONITORED)
      (PUSH ALARM FILES-TO-BE-MONITORED)))

;; Mail checks.  Notifies whenever the mail file of a user on this list is updated, but not
;; if it's deleted.  
(DEFVAR MAIL-CHECK-USERS NIL "List of info on which users we are searching for mail.
Each entry must be of the form (user host filename).")
(DEFVAR MAIL-CHECK-USERS-WITH-NEW-MAIL NIL "List of users' files that there is new mail for.")
(DEFVAR MAIL-CHECK-USERS-CREATION-DATE-ALIST NIL "An alist of info on the creation date 
of the mail files of the people we care about.")
(DEFVAR MAIL-CHECK-USERS-AUTHOR-LIST NIL "List of last writer of the mail files.")

(DEFUN (MAIL CHECK) ()
  (DO ((U MAIL-CHECK-USERS (CDR U))
       (USER) (HOST) (FILENAME) (OLD-ENTRY) (PROBE) (CREATION-DATE))
      ((NULL U))
    (SETQ USER (CAAR U)
	  HOST (CADAR U)
	  FILENAME (CADDAR U)
	  OLD-ENTRY (ASSOC (CAR U) MAIL-CHECK-USERS-CREATION-DATE-ALIST))
    (COND ((NOT (ERRORP (SETQ PROBE (OPEN FILENAME '(:PROBE)))))
	   (SETQ CREATION-DATE (FUNCALL PROBE ':CREATION-DATE))
	   (PUSH (OR (FUNCALL PROBE ':GET ':AUTHOR) "an unknown person")
		 MAIL-CHECK-USERS-AUTHOR-LIST)
	   (COND ((OR (NULL (CDR OLD-ENTRY))
		      ( CREATION-DATE (CDR OLD-ENTRY)))
		  (IF OLD-ENTRY
		      (SETF (CDR OLD-ENTRY) CREATION-DATE)
		      (PUSH (SETQ OLD-ENTRY (CONS (CAR U) CREATION-DATE))
			    MAIL-CHECK-USERS-CREATION-DATE-ALIST))
		  (PUSH OLD-ENTRY MAIL-CHECK-USERS-WITH-NEW-MAIL))))
	  (T (IF OLD-ENTRY (SETF (CDR OLD-ENTRY) NIL)))))
  MAIL-CHECK-USERS-WITH-NEW-MAIL)

(DEFUN (MAIL NOTIFY) (&OPTIONAL DONT-NOTIFY-P &AUX AUTHOR ENTRY PERSON)
  (OR DONT-NOTIFY-P
      (LOOP FOR N FROM 0 TO (1- (LENGTH MAIL-CHECK-USERS-WITH-NEW-MAIL))
	    DOING
	    (SETQ AUTHOR (NTH N MAIL-CHECK-USERS-AUTHOR-LIST))
	    (SETQ ENTRY (NTH N MAIL-CHECK-USERS-WITH-NEW-MAIL))
	    (SETQ PERSON (COND ((AND (EQUAL (CAAR ENTRY) USER-ID)
				     (EQ (CADAR ENTRY) FS:USER-LOGIN-MACHINE)) ;Hosts are EQ.
				"You have")
			       (T (FORMAT NIL "~A~:[@~A~] has"
					  (CAAR ENTRY)
					  (EQUAL (CADAR ENTRY) FS:USER-LOGIN-MACHINE)
					  (CADAR ENTRY)))))
	    (TV:NOTIFY NIL
		       (WITH-OUTPUT-TO-STRING (S)
			 (FORMAT S "~A new mail from ~A at " PERSON AUTHOR)
			 (TIME:PRINT-BRIEF-UNIVERSAL-TIME
			   (CDR (NTH N MAIL-CHECK-USERS-CREATION-DATE-ALIST)) S)))))
  (SETQ MAIL-CHECK-USERS-WITH-NEW-MAIL NIL)
  (SETQ MAIL-CHECK-USERS-AUTHOR-LIST NIL))

(DEFUN (MAIL PRINT) (STREAM &AUX (N 0))
  (FORMAT STREAM "~%MAIL Alarms:")
  (IF (NULL MAIL-CHECK-USERS)
      (FORMAT STREAM "  Nobody's mail file is being monitored.~%")
    (DOLIST (ENTRY MAIL-CHECK-USERS)
      (FORMAT STREAM "~%[~A] ~A's mail file ~A on host ~A is being monitored."
	      (INCF N) (FIRST ENTRY) (THIRD ENTRY) (SEND (SECOND ENTRY) ':NAME)))))
						
(DEFUN (MAIL RESET) ()
  (SETQ MAIL-CHECK-USERS NIL
	MAIL-CHECK-USERS-CREATION-DATE-ALIST NIL
	MAIL-CHECK-USERS-AUTHOR-LIST NIL
	MAIL-CHECK-USERS-WITH-NEW-MAIL NIL))

(DEFUN (MAIL REMOVE-ALARM) (N)
  (WITHOUT-INTERRUPTS
    (DELETE-ELEMENT N MAIL-CHECK-USERS)))

(DEFUN (MAIL ADD-ALARM) (ALARM)
  (PUSH ALARM MAIL-CHECK-USERS))

;; Make alarm go off at a certain time.
(DEFVAR ALARM-TIMES NIL
  "An alist of what times the alarms should go off.
Each entry is a list of the arguments provided from SET-ALARM:
TIME MESSAGE INTERVAL REPEAT-END-TIME ALSO-SHOW-MESSAGE-P FUNCTION ARGS")

(DEFUN (TIME CHECK) ()
  (> (TIME:GET-UNIVERSAL-TIME) (CAAR ALARM-TIMES)))

(DEFUN (TIME NOTIFY) (&OPTIONAL IGNORE &AUX REPEAT-ALARMS)
  (DO ((A ALARM-TIMES (CDR A)))
      ((NULL A) ;out of alarms
       (SETQ ALARM-TIMES NIL)
       (DELETE-ALARM 'TIME))
    ;Recontruct args as created by SET-ALARM
    (LET* ((ENTRY (CAR A))
	   (TIME (FIRST ENTRY))
	   (MESSAGE (SECOND ENTRY))
	   (INTERVAL (THIRD ENTRY))
	   (REPEAT-END-TIME (FOURTH ENTRY))
	   (ALSO-SHOW-MESSAGE-P (FIFTH ENTRY))
	   (FUNCTION (SIXTH ENTRY))
	   (ARGS (SEVENTH ENTRY)))
    (COND (( (TIME:GET-UNIVERSAL-TIME) TIME) ;trigger an alarm
	   (IF ALSO-SHOW-MESSAGE-P (TV:NOTIFY NIL MESSAGE))
	   (COND ((NOT (NULL FUNCTION)) ;gotta call a function
		  (IF (NULL ARGS)
		      (FUNCALL FUNCTION)
		    (APPLY FUNCTION ARGS))))
	   (COND ((AND (NOT (NULL INTERVAL)) ;repeatable alarm
		       (OR (NULL REPEAT-END-TIME) ;we always care
			   ( (+ TIME INTERVAL) REPEAT-END-TIME))
		       (PUSH (RPLACA ENTRY (+ TIME INTERVAL)) REPEAT-ALARMS))))) ;mung ENTRY
	  (T
	   (RETURN (SETQ ALARM-TIMES A)))))) ;out of alarms to notify
  (COND ((NOT (NULL REPEAT-ALARMS))  ;gotta add repeatable alarms
	 (DOLIST (ALARM REPEAT-ALARMS)
	   (FUNCALL (GET 'TIME 'ADD-ALARM) ALARM))))
  ALARM-TIMES) ;we used to return this, guess we still should

(DEFUN (TIME RESET) ()
  (SETQ ALARM-TIMES NIL))

(DEFUN (TIME PRINT) (STREAM &AUX (N 0))
  (FORMAT STREAM "~%TIME Alarms:")
  (IF (NULL ALARM-TIMES)
      (FORMAT STREAM "  You have no scheduled alarm notifications.~%")
    (DOLIST (ALARM ALARM-TIMES)
      (FORMAT STREAM "~%[~A] You have an alarm scheduled to go off at ~A.~%"
	      (INCF N) (TIME:PRINT-BRIEF-UNIVERSAL-TIME (FIRST ALARM) NIL)))))
;more info should be given

(DEFUN (TIME REMOVE-ALARM) (N)
  (WITHOUT-INTERRUPTS
    (DELETE-ELEMENT N ALARM-TIMES)))

(DEFUN (TIME ADD-ALARM) (ALARM)
  (WITHOUT-INTERRUPTS
    (SETQ ALARM-TIMES (SORTCAR (CONS ALARM ALARM-TIMES) #'<))))

	     
;; Make alarm go off when the status of a specified host changes.
;; As far as this program is concerned, there are three possible statuses for hosts:
;; UP, DOWN, or going down in a certain amount of time.  The status on the alist is
;; therefore always UP, DOWN, or a universal time of a planned shutdown.
;; Unfortunately no code exists to check for planned shutdowns, but when it does,
;; the only thing which should have to be modified is the CHECK function.


(DEFVAR ALWAYS-NOTIFY-IF-HOST-NOT-UP T
  "This us a user variable, and it overrides the inhibit notification stuff.")

(DEFVAR HOSTS-TO-CHECK NIL
  "A list of chaos addresses of hosts to check for a change in their up or down state.")
(DEFVAR HOSTS-TO-CHECK-LOCK NIL "Used to lock out processing of the HOSTS alarm.")
(DEFVAR HOSTS-CURRENT-STATUS NIL "List of hosts for which we know their present status.")
(DEFVAR HOSTS-WITH-NEW-STATUS NIL "List of hosts which have just gone up or down.")

(DEFUN (HOSTS CHECK) (&AUX CONNECTIONS CURRENT-STATUS)
  (UNWIND-PROTECT
    (PROGN (PROCESS-LOCK (LOCF HOSTS-TO-CHECK-LOCK))
	   (SETQ CONNECTIONS (MAKE-LIST (LENGTH HOSTS-TO-CHECK)))
	   (CHAOS:ASSURE-ENABLED)
	   (DO ((H HOSTS-TO-CHECK (CDR H))
		(C CONNECTIONS (CDR C)))
	       ((NULL C))
	     (SETF (CAR C) (CHAOS:OPEN-CONNECTION (CAR H) "STATUS" 1)))
	   (SETQ HOSTS-TO-CHECK-LOCK NIL)
	   ;; Wait a maximum of 5 seconds for the replys to come in.
	   (PROCESS-WAIT-WITH-TIMEOUT "Host Status" 600.
	     #'(LAMBDA (CONNS)
		 (DO ((C CONNS (CDR C)))
		     ((NULL C) T)
		   (AND (EQ (CHAOS:STATE (CAR C)) 'CHAOS:RFC-SENT-STATE)
			(RETURN NIL))))
	     CONNECTIONS)
	   (DO ((C CONNECTIONS (CDR C)))
	       ((NULL C))
	     (SETQ CURRENT-STATUS (CDR (ASSQ (CHAOS:FOREIGN-ADDRESS (CAR C))
					     HOSTS-CURRENT-STATUS)))
	     (SELECTQ (CHAOS:STATE (CAR C))
	       ((CHAOS:RFC-SENT-STATE CHAOS:HOST-DOWN-STATE)
		(COND ((NEQ CURRENT-STATUS 'DOWN)
		       (PUSH (CONS (CHAOS:FOREIGN-ADDRESS (CAR C)) 'DOWN)
			     HOSTS-WITH-NEW-STATUS))))
	       (OTHERWISE
		(COND ((NEQ CURRENT-STATUS 'UP)
		       (PUSH (CONS (CHAOS:FOREIGN-ADDRESS (CAR C)) 'UP)
			     HOSTS-WITH-NEW-STATUS)))))))
    (%STORE-CONDITIONAL (LOCF HOSTS-TO-CHECK-LOCK) CURRENT-PROCESS NIL)
    (DOLIST (C CONNECTIONS)
      (CHAOS:REMOVE-CONN C)))
  HOSTS-WITH-NEW-STATUS)

 ;;macro!  (defun chaos:remove-connections ...   work with erros.

(DEFUN (HOSTS NOTIFY) (&OPTIONAL DONT-NOTIFY-P &AUX TEM)
  (DOLIST (H HOSTS-WITH-NEW-STATUS)
    (AND (OR (NOT DONT-NOTIFY-P)
	     (AND ALWAYS-NOTIFY-IF-HOST-NOT-UP
		  (NEQ (CDR H) 'UP)))
	 (TV:NOTIFY NIL
	   (WITH-OUTPUT-TO-STRING (S)
	     (FUNCALL S ':STRING-OUT (CHAOS:HOST-SHORT-NAME (CAR H)))
	     (COND ((NUMBERP (CDR H))
		    (FUNCALL S ':STRING-OUT " is going down at ")
		    (TIME:PRINT-UNIVERSAL-TIME (CDR H) S))
		   (T (FUNCALL S ':STRING-OUT
			       (COND ((EQ (CDR H) 'UP) " is up.")
				     (T " is down."))))))))
    (COND ((SETQ TEM (ASSOC (CAR H) HOSTS-CURRENT-STATUS))
	   (RPLACD TEM (CDR H)))
	  (T (PUSH H HOSTS-CURRENT-STATUS))))
  (SETQ HOSTS-WITH-NEW-STATUS NIL))

 (DEFUN (HOSTS RESET) ()
  (SETQ HOSTS-TO-CHECK NIL
	HOSTS-TO-CHECK-LOCK NIL
	HOSTS-CURRENT-STATUS NIL
	HOSTS-WITH-NEW-STATUS NIL))

(DEFUN (HOSTS PRINT) (STREAM &AUX (N 0))
  (FORMAT STREAM "~%HOSTS Alarms:")
  (IF (NULL HOSTS-TO-CHECK)
      (FORMAT STREAM "  You are not monitoring the status of any hosts.~%")
    (DOLIST (HOST HOSTS-TO-CHECK)
      (FORMAT STREAM "~%[~A] You will be notified if the status of host ~A changes."
	      (INCF N) (SEND HOST ':NAME)))))

(DEFUN (HOSTS REMOVE-ALARM) (N)
  (WITHOUT-INTERRUPTS
    (DELETE-ELEMENT N HOSTS-TO-CHECK)))

(DEFUN (HOSTS ADD-ALARM) (NEW-ALARM &AUX HOST)
  (COND ((NUMBERP NEW-ALARM) (SETQ HOST NEW-ALARM))
	((SETQ HOST (CHAOS:ADDRESS-PARSE NEW-ALARM)))
	(T (FERROR NIL "~S is not a known host." NEW-ALARM)))
  (UNWIND-PROTECT
    (PROGN (PROCESS-LOCK (LOCF HOSTS-TO-CHECK-LOCK))
	   (OR (MEMQ HOST HOSTS-TO-CHECK)
	       (PUSH HOST HOSTS-TO-CHECK)))
    (%STORE-CONDITIONAL (LOCF HOSTS-TO-CHECK-LOCK) CURRENT-PROCESS NIL)))

;; Make alarm go off when a Lispm frees up.
;; Here CHAOS:FINGER-ALL-LMS does all the work for us.
(DEFVAR FREE-LISPMS NIL  "List of free lisp machines.  Initially, NIL")
(DEFVAR NEW-FREE-LISPMS NIL "List of lisp machines which have just become free.")

(DEFUN (LISPM CHECK) ()
  (LET ((LISPMS (CHAOS:FINGER-ALL-LMS  'IGNORE NIL T)))
    (DOLIST (LISPM LISPMS)
      (COND ((NOT (MEMBER LISPM FREE-LISPMS))
	     (PUSH LISPM NEW-FREE-LISPMS))))
    (SETQ FREE-LISPMS LISPMS)))

(DEFUN (LISPM NOTIFY) (&OPTIONAL DONT-NOTIFY-P)
  (DOLIST (LISPM NEW-FREE-LISPMS)
    (OR DONT-NOTIFY-P
	(TV:NOTIFY NIL "~A is free." LISPM)))
  (SETQ NEW-FREE-LISPMS NIL))

(DEFUN (LISPM PRINT) (STREAM)
  (FORMAT STREAM "~%LISPM Alarms: (unknown)"))

;; These properties are inappropriate, because this alarm only searches
;; for one type of alarm.
(DEFPROP LISPM IGNORE RESET)
(DEFPROP LISPM IGNORE NEW-ALARM)
(DEFPROP LISPM IGNORE REMOVE-ALARM) ;foo


;;; User interface functions.
;;; These are the functions that a user would normally call in an init file.
;;; Someday write a mouse interface.

(DEFF BACKGROUND-MAIL-CHECK 'BACKGROUND-CHECK-MAIL) ;humaness

(DEFUN BACKGROUND-CHECK-MAIL (&OPTIONAL (USER USER-ID)(HOST FS:USER-LOGIN-MACHINE)
			      FILENAME NOTIFY-INITIALLY-P)
"In a background process, check every so often to see if a particular
user at a particular host has new mail and who the mail is from.
With no arguments, it will check for your mail on the  host that
you logged into.  NOTIFY-INITIALLY-P if NIL will not bother to notify
you when new mail arrives, if T it will.  It defualts to T"
  (IF (NULL FILENAME) (SETQ FILENAME (SEND (FS:USER-HOMEDIR) ':NEW-MAIL-PATHNAME)))
  (SETQ HOST (SI:PARSE-HOST HOST))
  (FUNCALL (GET 'MAIL 'ADD-ALARM) (LIST USER HOST (FS:MERGE-PATHNAME-DEFAULTS FILENAME)))
  (OR NOTIFY-INITIALLY-P
      (SET-ALARM-INHIBIT-NOTIFY 'MAIL))
  (ADD-ALARM 'MAIL)
  T)

(DEFUN BACKGROUND-CHECK-FILES (NOTIFY-INITIALLY-P &REST FILES)
  "In a background process, notify when a file is modified."
  (DOLIST (FILE FILES)
    (FUNCALL (GET 'FILE 'ADD-ALARM) FILE))
  (OR NOTIFY-INITIALLY-P
      (SET-ALARM-INHIBIT-NOTIFY 'FILE))
  (ADD-ALARM 'FILE)
  T)

(DEFUN SET-ALARM (TIME &OPTIONAL (MESSAGE "It is now the time that you scheduled an alarm.")
		  (REPEAT-INTERVAL "never") REPEAT-END-TIME ALSO-SHOW-MESSAGE-P
		  FUNCTION &REST ARGS)
  "Set an alarm, so that you will be notified when the specified TIME arrives, 
by having the string MESSAGE forcably displayed on your terminal.

If REPEAT-INTERVAL is specified, then repeat that alarm every time the amount of time
in REPEAT-INTERVAL passes.  Stop repeating the alarm after REPEAT-END-TIME, or
continue forever if REPEAT-END-TIME is NIL (the default).  

If FUNCTION is supplied, the FUNCTION will be called with the arguments
of ARGS instead of you being notified of the MESSAGE, unless ALSO-SHOW-MESSAGE-P is T."
  (LET ((TIME (TIME:PARSE-UNIVERSAL-TIME TIME))
	(INTERVAL (TIME:PARSE-INTERVAL-OR-NEVER REPEAT-INTERVAL))
	(ARGS (COPYLIST ARGS)))
    (AND (NOT (NULL INTERVAL))
	 (< (* 60. INTERVAL) ALARM-SLEEP-TIME) ;boy are you trying to lose1
	 (SETQ INTERVAL (TRUNCATE ALARM-SLEEP-TIME 60.)) ;minutes vs. seconds
	 (TV:NOTIFY NIL "Coercing INTERVAL to be ~A, the ALARM-SLEEP-TIME."
		    (TIME:PRINT-INTERVAL-OR-NEVER INTERVAL NIL)))
    (IF (NOT (NULL REPEAT-END-TIME))
	(SETQ REPEAT-END-TIME (TIME:PARSE-UNIVERSAL-TIME REPEAT-END-TIME)))
    (IF (NULL FUNCTION) (SETQ ALSO-SHOW-MESSAGE-P T))
    (FUNCALL (GET 'TIME 'ADD-ALARM)
	     (LIST TIME MESSAGE INTERVAL REPEAT-END-TIME ALSO-SHOW-MESSAGE-P FUNCTION ARGS))
  (ADD-ALARM 'TIME)
  T))

;; By default, the background host stuff will always notify if the host is not up.
;; See the variable ALWAYS-NOTIFY-IF-HOST-NOT-UP.   It's a kludge, but...

(DEFUN BACKGROUND-CHECK-HOSTS (NOTIFY-INITIALLY-P &REST HOSTS)
  "Notify me when one of the hosts specified goes up or down."
  (DO ((H HOSTS (CDR H))) ((NULL H))
    (FUNCALL (GET 'HOSTS 'ADD-ALARM) (CAR H)))
  (OR NOTIFY-INITIALLY-P
      (SET-ALARM-INHIBIT-NOTIFY 'HOSTS))
  (ADD-ALARM 'HOSTS)
  T)

;; Note that this also updates the variable FREE-LISPMS
(DEFUN CHECK-FREE-LISPMS (&OPTIONAL NOTIFY-INITIALLY-P)
"In a background process, check every so often a change
in free lisp machines.  With NOTIFY-INITALLY-P of T,
don't bother to notify me.  Defaults so that you 
will be be notified."
  (OR NOTIFY-INITIALLY-P
      (SET-ALARM-INHIBIT-NOTIFY 'LISPM))
  (ADD-ALARM 'LISPM))

(DEFVAR ALARM-TYPE-LIST '(TIME FILE HOSTS LISPM MAIL) "A list of know types of alarm.")

(DEFUN PRINT-ALARM (&OPTIONAL ALARM (STREAM STANDARD-OUTPUT))
  "Display information about a particular alarm."
  (PRINT-ALARMS STREAM (LIST ALARM)))

(DEFUN PRINT-ALARMS (&OPTIONAL (STREAM STANDARD-OUTPUT) (ALARM-LIST ALARM-TYPE-LIST))
  "Display information on all alarms."
  (FORMAT STREAM "~%Alarms are checked every ~A.~%"
	  (TIME:PRINT-INTERVAL-OR-NEVER (TRUNCATE ALARM-SLEEP-TIME 60.) NIL))
  (DOLIST (ALARM ALARM-TYPE-LIST)
    (FUNCALL (GET ALARM 'PRINT) STREAM)))
       
 ;;this function is dangerous!!
(DEFUN REMOVE-ALARM-INTERNAL (ALARM ALARM-NUMBER)
  "Remove a particular alarm those alarms to be checked."
  (FUNCALL (GET ALARM 'REMOVE-ALARM) ALARM-NUMBER))

  ;users want to call this

(DEFUN VIEW-ALARMS ()
  "Supply a menu with a list of alarms to delete."
  ;;;Lock alarm database first!!un
  (LET* ((ALIST (LOOP FOR ALARM IN ALARM-TYPE-LIST
		      COLLECT (LIST ALARM (STRING ALARM) '(:VIEW :REMOVE))))
	 (BLIST (LOOP FOR THING IN '(:VIEW :REMOVE)
		      COLLECT (LIST THING (STRING-CAPITALIZE-WORDS (STRING THING)))))
	 (RESPONSE (TV:MULTIPLE-CHOOSE "Operate on some alarms." ALIST BLIST)))
    (DOLIST (ELT RESPONSE)
      (LET ((ALARM (CAR ELT)))
	(IF (MEMQ ':VIEW ELT)
	    (VIEW-ALARM ALARM))
	(IF (MEMQ ':REMOVE ELT)
	    (REMOVE-ALARM ALARM))))))

(DEFUN VIEW-ALARM (ALARM)
  ALARM)

;;greatly improve the user interface

(DEFUN REMOVE-ALARM (&OPTIONAL ALARM ALARM-NUMBER CONFIRM)
  "Remove a specific alarm.  Asks the user for confirmation."
  ;;cond-every !
  (COND ((NULL ALARM)
	 (FORMAT QUERY-IO "~%Please type in the name an alarm (or just return to quit).
Valid alarms are ~A." (PRINT-LIST ALARM-TYPE-LIST QUERY-IO))
	 (SETQ ALARM (READLINE QUERY-IO))))
  (COND ((AND (NOT (NULL ALARM)) (NULL ALARM-NUMBER))
	 (FORMAT QUERY-IO "Please type the number of the ~A alarm that you want to be rid of." ALARM)
	 (SETQ ALARM-NUMBER (PARSE-NUMBER (READLINE QUERY-IO)))))
  (COND ((AND (NOT (NULL ALARM)) ( 0 ALARM-NUMBER))
	 (IF (NULL CONFIRM)
	     (SETQ CONFIRM (Y-OR-N-P
			     (FORMAT NIL "Do you really want to remove yourself of alarm number ~A?" ALARM-NUMBER))))
	 (IF CONFIRM (REMOVE-ALARM-INTERNAL ALARM ALARM-NUMBER)))))

      
(DEFUN PRINT-LIST (LIST STREAM)
  "A simpler version of format:print list."
  (COND ((NULL LIST)
	 (FORMAT STREAM "none"))
	((= (LENGTH LIST) 1)
	  (FORMAT STREAM "~A"))
	((= (LENGTH LIST) 2)
	 (FORMAT STREAM "~A and ~A" (FIRST LIST) (SECOND LIST)))
	(T
	 (DOTIMES (N (1- (LENGTH LIST)))
	   (FORMAT STREAM "~A, " (NTH N LIST)))
	 (FORMAT STREAM "and ~A" (NTH (LENGTH LIST) LIST)))))