;;;; Variable system:  persistent variables for Yenta.

;;; All values stored in variables used by this system should have the property
;;; that they be equivalent to the internal representation of the external
;;; representation of the value.  This means:
;;;  all symbols, number, characters, and strings are allowed.
;;;  lists are allowed, but may not be circular, and should not be expected to
;;;    be eq? to their parts.
;;;  vectors are allowed, with the same restrictions as lists.
;;;  procedures, ports, and other complex primitive types are not allowed.
;;; However, other values can be saved by providing a save-proc.  This allows
;;; Savant collections to be saved, for example.
;;;
;;; (def-yenta-var <name> <initial-value> {<save-proc>})
;;; defines <name> to <initial-value>, if it is not defined already, and notes
;;; it so that it will be saved.  The proper ordering is to load the variables, 
;;; and then define all of the variables, which will have no effect for old
;;; variables, and will add new variables.  This is unnecessary once the set of
;;; variables has stabilized.  <save-proc>, if provided, should evaluate *in the
;;; initial global environment* to a procedure of one argument that takes the
;;; value of the variable to be saved and returns an expression that, if
;;; evaluated, will return the saved value.  The save-proc is called when the
;;; value is to be saved.
;;;
;;; (def-yenta-param <name> <init> <short> <long> <convert> <keys> 
;;;                  {<save-proc>})
;;; defines <name> to <initial-value>, if it is not defined already, and makes
;;; it persist as per def-yenta-var.  The parameter will be described in forms
;;; as <short>, and <long> will be given afterward as an explanation if needed.
;;; <convert> will be called on the string reply, which it should validate and
;;; return *in a one element list* if valid, or #f otherwise.  <keys> is a list
;;; of keywords used to search for the parameters which should be listed together.
;;;
;;; (vars:save-vars)
;;; Saves the values of all noted variables to ~/.Yenta/vars.scm (or some other
;;; place if *yenta-name-override* is set).
;;;
;;; (vars:load-vars)
;;; loads the values of all saved variables, and sets exactly these to be saved.

;;; NOTE:  It would be logical to do (yreq "Scheduler/scheduler") here, because
;;; we schedule tasks at the end of this file, but doing so will lead to a yreq
;;; loop, since both are used so early.  Don't sweat it; this will work anyway.

(yreq "Utilities/yenta-utils")

(defmacro def-yenta-var (name init . save-proc-pair)
  `(begin
     (if (not (defined? ,name))
	 (define ,name ,init))
     (if (not (assq ',name *vars:vars*))
	 (set! *vars:vars* (cons (cons ',name ',save-proc-pair)
				 *vars:vars*)))))

(defmacro def-yenta-param (name init short long convert keys . save-proc-pair)
  `(begin
     (set! *vars:params* (cons (list ',name ',short ',long ',convert ',keys)
			       *vars:params*))
     (def-yenta-var ,name ,init . ,save-proc-pair)))

(define (vars:filtered-param-list keys)
  (filter (lambda (item) (for-all? (lambda (key) 
				     (memq key (list-ref item 4)))
				   keys))
	  *vars:params*))

(define (vars:simple-param-list keys)
  (map (lambda (item)
	 (list (car item) (eval (car item))))  	 ; (name value) pairs
       (vars:filtered-param-list keys)))

(define (vars:param-form desc keys)
  (flatten 
   (map (lambda (item)
	  (append (list "<p><b>" (cadr item) " = </b><input type = text name = "
			(car item) " value = " (eval (car item)) ">")
		  (if desc (list "<br>" (caddr item) "</p>")
		      (list "</p>"))))
	(vars:filtered-param-list keys))))

(define (vars:param-list desc keys)
  (ui:pretty-html-exp-list
   (map (lambda (item)
	  (append (list (cadr item) " = " (eval (car item)))
		  (if desc (list "<br>" (caddr item))
		      '())))
	(vars:filtered-param-list keys))))

;;; +++ These actually convert to a list of the item in question, since vars:use-form expects that.
;;; +++ They return #f for an error.
(define (vars:->number str)
  (let ((value (string->number str)))
    (if value
	(list value)
	#f)))
(define (vars:->nonneg-number str)
  (let ((value (string->number str)))
    (if (and value
	     (>= value 0))
	(list value)
	#f)))
(define (vars:->[0-1] str)		; [0,1] isn't legal scheme syntax; too bad.
  (let ((value (string->number str)))
    (if (and value
	     (<= 0 value 1))
	(list value)
	#f)))
;;; Since this must be persistently stored, we can valididate the pattern here,
;;; but must return (and hence store) the uncompiled one.  Unfortunately, I don't
;;; see a nice way of returning the exact error to the user if it fails...
;;; [Note that an -explanation- of the error is available by calling (regerror),
;;;  but I'm not sure what the flow should be to get that to the user.]
(define (vars:->regexp string)
  (let ((result (regcomp string)))
    (if (number? result)
	#f				; Failure.
	(list string))))
;;; ---

(define (vars:use-form)			; This assumes that the value returned is a singleton list of a valid value, -or- just #f for an error.
  (flatten
   (map (lambda (item)
	  (eval `(let* ((resp ,(ui:form-datum 
				(symbol->string (car item))))
			(value (if resp (,(cadddr item) resp)
				   resp)))
		   (cond (value
			  (set! ,(car item) (car value))
			  '())
			 (t
			  (if resp
			      `("<b>Sorry, but <i>" ,,(cadr item) "</i> cannot be set to <i>"
				      ,(ui:literal resp) "</i>.  Please try again.</b>")
			      '()))))))
	(vars:filtered-param-list '(settable)))))

;;; This writes its output to a temporary file and then, if we're still
;;; up when we're done, renames it atomically over the original, depending
;;; on UNIX renaming semantics to make this atomic even across, e.g., NFS or AFS.
;;; The point of this is to avoid mangling the user's vars.scm if we somehow
;;; take a crash in the middle---after all, if we truncate the file (either
;;; due to a crash or out-of-disk or whatever), we destroy his keys, which
;;; are the very basis of his identity!  This could be a very costly screwup.
;;; I -assume- that close-port will correctly, and immediately, flush all
;;; data to disk.  I don't really know of any way of enforcing this on NFS
;;; if that's not the way all implementations do it.
;;;
;;; %%% If we run out of disk space, I presume that the task will be killed.
;;; We should probably try to reschedule it at some point, although of course
;;; it'll just be killed again if we're still out of space---_and_ our tempfile(s)
;;; will still be around, sucking up yet more space.  We probably need to special-case
;;; this with some sort of watchdog, which kills -all- tempfiles and restarts the
;;; task if it dies---hopefully after a suitable interval, so we don't wind up
;;; hard-looping doing this constantly.
(define (vars:save-vars)		; [Note that THIS IS STILL USED by non-user versions of Yenta, like the logger, bootserver, ...]
  (let* ((base (yenta-name "vars.scm"))
	 (name (format nil "~A.~A" base (getpid)))
	 (file (open-output-file name)))
    ;; First, get the data committed to disk.
    (for-each (lambda (var-rec)
		(cond ((null? (cdr var-rec))
		       (write `(define ,(car var-rec) ',(eval (car var-rec))) file)
		       (newline file))
		      (t
		       (write ((eval (cadr var-rec)) (car var-rec)) file)
		       (newline file))))
	      *vars:vars*)
    (write `(define *vars:vars* ',*vars:vars*) file)
    (newline file)
    (close-port file)
    ;; Second, put it in the right file.
    (let ((succeeded? (rename-file name base)))		; %%% I don't know what to do with an error!  Log it?  Try again?
      (unless succeeded?
	(logger:log-and-display 0 "Couldn't rename ~A to ~A while saving state." name base)))))

;;; Utilities for vars:load-vars.  This is like comlist:adjoin & comlist:union,
;;; but they expect each list element to be itself a list, and compare their cars.
;;; NOTE that, if you have two -different- definitions for the same car, e.g.,
;;; (vars:union-car '((a foo)) '((a bar))), the result is unpredictable!
(define (vars:adjoin-car e l) (if (assq (car e) l) l (cons e l))) ; Like comlist:adjoin, but assq instead of memq.
(define (vars:union-car l1 l2)		; Like comlist:adjoin, but calls vars:union-car & vars:adjoin-car instead of comlist functions.
  (cond ((null? l1) l2)			; [No other changes.]
	((null? l2) l1)
	(else (vars:union-car (cdr l1) (vars:adjoin-car (car l1) l2)))))

;;; We cannot just load the value of *vars:vars* from the file as-is.
;;; If some later version of Yenta has created a new yvar, then the setting
;;; of *vars:vars* in the dumped image will be overridden the first time we
;;; call vars:load-vars and it loads the existing vars.scm, which is, by definition,
;;; one corresponding to an older Yenta.  Hence, new yvars will never stick,
;;; because we will never dump the new variable after loading the old file,
;;; because we only dump variables mentioned in *vars:vars*, which has just
;;; been bashed.  To solve this, we union the set of variables in the vars.scm
;;; file with the current set in the dumped image.  If some later Yenta release
;;; wants to -remove- yvars, it'll have to special-case that by removing the
;;; yvar from *vars:vars* by hand.
(define (vars:load-vars)		; [Note that THIS IS STILL USED by non-user versions of Yenta, like the logger, bootserver, ...]
  (let ((old-vars (copy-list *vars:vars*))) ; I dunno if the copy-list is strictly necessary, but it seems safer...
    (try-load (yenta-name "vars.scm"))
    (set! *vars:vars* (vars:union-car old-vars *vars:vars*))))

;;; Defvar, not define!  Otherwise, loading this file again nukes any existing ones.
(defvar *vars:vars* '())
(defvar *vars:params* '())

;;;; Arranging to periodically save our state.

;;; This could be made a -lot- more intelligent, e.g. don't bother saving if
;;; nothing has happened, and save much more frequently if we're saving lots
;;; of messages, etc etc.  For now, this will have to do.

(define *vars:checkpoint-taskname* "Checkpoint periodically")
(define *vars:checkpoint-priority* 3)
(define *vars:checkpoint-period* 3600)	; An hour.

(define (vars:start-checkpointing)
  (scheduler:add-periodic-task!		; The first checkpoint will happen one period -after- this runs, which is correct.
    *vars:checkpoint-taskname* *vars:checkpoint-priority* *vars:checkpoint-period*
    vars:save-encrypted))

;;; End of file.
