Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -46,23 +46,23 @@ (let ((remcwd (take dir (- (length dir) 1)))) (if (null? remcwd) (list #f #f #f) ;; #f #f) (loop remcwd))))))))) -(define (configf:assoc-safe-add alist key val #!key (metadata #f)) +(define (config:assoc-safe-add alist key val #!key (metadata #f)) (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist))) (append newalist (list (if metadata (list key val metadata) (list key val)))))) (define (configf:section-var-set! cfgdat section-name var value #!key (metadata #f)) (hash-table-set! cfgdat section-name - (configf:assoc-safe-add + (config:assoc-safe-add (hash-table-ref/default cfgdat section-name '()) var value metadata: metadata))) -(define (configf:eval-string-in-environment str) +(define (config:eval-string-in-environment str) ;; (if (or (string-null? str) ;; (equal? "!" (substring str 0 1))) ;; null string or starts with ! are preserved but NOT set in the environment str (handle-exceptions exn @@ -241,11 +241,11 @@ (lambda (bundle) ;; (print "bundle: " bundle) (let ((key (car bundle)) (val (cadr bundle)) (meta (if (> (length bundle) 2)(caddr bundle) #f))) - (hash-table-set! ht section (configf:assoc-safe-add (hash-table-ref ht section) key val metadata: meta)))) + (hash-table-set! ht section (config:assoc-safe-add (hash-table-ref ht section) key val metadata: meta)))) vars))))) (hash-table-keys ht)))) ht) ;; read a config file, returns hash table of alists @@ -419,11 +419,11 @@ (debug:print-info 9 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)) (if (null? res) "" (string-intersperse res " ")))))) (hash-table-set! res curr-section-name - (configf:assoc-safe-add alist + (config:assoc-safe-add alist key (case (calc-allow-system allow-system curr-section-name sections) ((return-procs) val-proc) ((return-string) cmd) (else (val-proc))) @@ -438,11 +438,11 @@ (let* ((alist (hash-table-ref/default res curr-section-name '())) (fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces) (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = #t") (safe-setenv key fval) (hash-table-set! res curr-section-name - (configf:assoc-safe-add alist key fval metadata: metapath)) + (config:assoc-safe-add alist key fval metadata: metapath)) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name key #f))) @@ -453,17 +453,17 @@ (and (not (string-null? key)) (not (equal? "!" (substring key 0 1)))) ;; ! as leading character is a signature to NOT export to the environment ;; (string-match "^.*:.*:.*$" key) ;; ;; something:something:something reserved for triggers in runconfigs )) (realval (if envar - (configf:eval-string-in-environment val) + (config:eval-string-in-environment val) val))) (debug:print-info 6 *default-log-port* "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) (if envar (safe-setenv key realval)) (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = " val) (hash-table-set! res curr-section-name - (configf:assoc-safe-add alist key realval metadata: metapath)) + (config:assoc-safe-add alist key realval metadata: metapath)) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name key #f))) ;; if a continued line (configf:cont-ln-rx ( x whsp val ) @@ -476,11 +476,11 @@ (string-substitute (regexp lead) "" whsp) "") val))) ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag) (hash-table-set! res curr-section-name - (configf:assoc-safe-add alist var-flag newval metadata: metapath)) + (config:assoc-safe-add alist var-flag newval metadata: metapath)) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp))) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) (else (debug:print-error 0 *default-log-port* "problem parsing " path ",\n \"" inl "\"") (set! var-flag #f) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) @@ -524,11 +524,10 @@ ;; (configf:var-is? cfgdat "foo" "var" "yes") => #t ;; (define (configf:var-is? cfgdat section var expected-val) (equal? (configf:lookup cfgdat section var) expected-val)) -;; redefines (define config-lookup configf:lookup) (define configf:read-file read-config) ;; safely look up a value that is expected to be a number, return ;; a default (#f unless provided) @@ -553,15 +552,14 @@ (hash-table-ref/default cfgdat section '())) (define (configf:set-section-var cfgdat section var val) (let ((sectdat (configf:get-section cfgdat section))) (hash-table-set! cfgdat section - (configf:assoc-safe-add sectdat var val)))) + (config:assoc-safe-add sectdat var val)))) -;;====================================================================== -;;(append (filter (lambda (x)(not (assoc var sectdat))) sectdat) -;; (list var val)))) + ;;(append (filter (lambda (x)(not (assoc var sectdat))) sectdat) + ;; (list var val)))) (define (setup) (let* ((configf (find-config "megatest.config")) (config (if configf (read-config configf #f #t) #f))) (if config Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -202,11 +202,11 @@ (cadr (cddr dat)))))) (begin (if dbprep-found (begin (debug:print-info 0 *default-log-port* "Server is in dbprep at " (current-seconds)) - (thread-sleep! 25) + (thread-sleep! 0.5) ;; was 25 sec but that blocked things from starting? ) (debug:print-info 0 *default-log-port* "Unable to get server info from " logf " at " (current-seconds)) ) (list #f #f #f #f))))))))) @@ -405,26 +405,29 @@ (server:wait-for-server-start-last-flag areapath) (if (not (server:check-if-running areapath)) ;; why try if there is already a server running? (let* ((last-run-dat (hash-table-ref/default *server-kind-run* areapath '(0 0))) ;; callnum, whenrun (call-num (car last-run-dat)) (when-run (cadr last-run-dat)) - (run-delay (+ (case call-num + (run-delay (+ (case call-num ;; NOT USED. Waiting is handled by wait-for-server ((0) 0) ((1) 20) ((2) 300) (else 600)) - (random 5))) ;; add a small random number just in case a lot of jobs hit the work hosts simultaneously + (random 5) + 0)) ;; add a small random number just in case a lot of jobs hit the work hosts simultaneously + (lock-file (conc areapath "/logs/server-start.lock"))) - (if (> (- (current-seconds) when-run) run-delay) - (let* ((start-flag (conc areapath "/logs/server-start-last"))) - (common:simple-file-lock-and-wait lock-file expire-time: 15) - (debug:print-info 0 *default-log-port* "server:kind-run: touching " start-flag) - (system (conc "touch " start-flag)) ;; lazy but safe - (server:run areapath) - (thread-sleep! 2) ;; don't release the lock for at least a few seconds - (common:simple-file-release-lock lock-file))) - (hash-table-set! *server-kind-run* areapath (list (+ call-num 1)(current-seconds)))))) + ;; (if (> (- (current-seconds) when-run) run-delay) + (let* ((start-flag (conc areapath "/logs/server-start-last"))) + (common:simple-file-lock-and-wait lock-file expire-time: 15) + (debug:print-info 0 *default-log-port* "server:kind-run: touching " start-flag) + (system (conc "touch " start-flag)) ;; lazy but safe + (server:run areapath) + (thread-sleep! 2) ;; don't release the lock for at least a few seconds + (common:simple-file-release-lock lock-file))) + (debug:print-info 0 *default-log-port* "Found server already running. NOT trying to start another."))) + ;; (hash-table-set! *server-kind-run* areapath (list (+ call-num 1)(current-seconds)))))) ;; this one seems to be the general entry point ;; (define (server:start-and-wait areapath #!key (timeout 60)) (let ((give-up-time (+ (current-seconds) timeout)))