Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -12,11 +12,11 @@ (use format) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) (import canvas-draw-iup) -(use regex typed-records) +(use regex typed-records matchable) (declare (unit dcommon)) (declare (uses megatest-version)) (declare (uses gutils)) @@ -620,11 +620,12 @@ #:numlin-visible 5 )) (colnames (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "RunTime" "State" "RunId")) (updater (lambda () (if (dashboard:monitor-changed? commondat tabdat) - (let ((servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))) + (let ((servers (server:get-list *toppath*))) + ;; (tasks:get-all-servers (db:delay-if-busy tdbdat)))) (iup:attribute-set! servers-matrix "NUMLIN" (length servers)) ;; (set! colnum 0) ;; (for-each (lambda (colname) ;; ;; (print "colnum: " colnum " colname: " colname) ;; (iup:attribute-set! servers-matrix (conc "0:" colnum) colname) @@ -632,36 +633,40 @@ ;; colnames) (set! rownum 1) (for-each (lambda (server) (set! colnum 0) - (let* ((vals (list (vector-ref server 0) ;; Id - (vector-ref server 9) ;; MT-Ver - (vector-ref server 1) ;; Pid - (vector-ref server 2) ;; Hostname - (conc (vector-ref server 3) ":" (vector-ref server 4)) ;; IP:Port - (seconds->hr-min-sec (- (current-seconds)(vector-ref server 6))) - ;; (vector-ref server 5) ;; Pubport - ;; (vector-ref server 10) ;; Last beat - ;; (vector-ref server 6) ;; Start time - ;; (vector-ref server 7) ;; Priority - ;; (vector-ref server 8) ;; State - (vector-ref server 8) ;; State - (vector-ref server 12) ;; RunId - ))) - (for-each (lambda (val) - (let* ((row-col (conc rownum ":" colnum)) - (curr-val (iup:attribute servers-matrix row-col))) - (if (not (equal? (conc val) curr-val)) - (begin - (iup:attribute-set! servers-matrix row-col val) - (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum)))) - (set! colnum (+ 1 colnum)))) - vals) - (set! rownum (+ rownum 1))) - (iup:attribute-set! servers-matrix "REDRAW" "ALL")) - servers)))))) + (match-let (((mod-time host port start-time pid) + server)) + (let* ((uptime (- (current-seconds) mod-time)) + (runtime (if start-time + (- (current-seconds) start-time) + 0)) + (vals (list "-" ;; (vector-ref server 0) ;; Id + "-" ;; (vector-ref server 9) ;; MT-Ver + pid ;; (vector-ref server 1) ;; Pid + host ;; (vector-ref server 2) ;; Hostname + (conc host ":" port) ;; (conc (vector-ref server 3) ":" (vector-ref server 4)) ;; IP:Port + (seconds->hr-min-sec runtime) ;; (- (current-seconds) start-time)) ;; (vector-ref server 6))) + (cond + ((< uptime 5) "alive") + ((< uptime 16) "probably alive");; less than 15 seconds since mod, call it alive (vector-ref server 8) ;; State + (else "dead")) + "-" ;; (vector-ref server 12) ;; RunId + ))) + (for-each (lambda (val) + (let* ((row-col (conc rownum ":" colnum)) + (curr-val (iup:attribute servers-matrix row-col))) + (if (not (equal? (conc val) curr-val)) + (begin + (iup:attribute-set! servers-matrix row-col val) + (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum)))) + (set! colnum (+ 1 colnum)))) + vals) + (set! rownum (+ rownum 1))) + (iup:attribute-set! servers-matrix "REDRAW" "ALL"))) + (sort servers (lambda (a b)(< (car a)(car b)))))))))) (set! colnum 0) (for-each (lambda (colname) (iup:attribute-set! servers-matrix (conc "0:" colnum) colname) (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum)) (set! colnum (+ colnum 1))) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -162,15 +162,27 @@ (string->number (cadr dat)) ;; port (string->number (caddr dat)))))) (list #f #f #f))))))) ;; get a list of servers with all relevant data -;; ( mod-time host port start-time ) +;; ( mod-time host port start-time pid ) ;; (define (server:get-list areapath) (let ((fname-rx (regexp "^(|.*/)server-(\\d+)-(\\S+).log$"))) - (if (directory-exists? areapath) + ;; if the directory exists continue to get the list + ;; otherwise attempt to create the logs dir and then + ;; continue + (if (if (directory-exists? (conc areapath "/logs")) + #t + (if (file-write-access? areapath) + (begin + (condition-case + (create-directory (conc areapath "/logs") #t) + (exn (i/o file)(debug:print 0 *default-log-port* "ERROR: Cannot create directory at " (conc areapath "/logs"))) + (exn ()(debug:print 0 *default-log-port* "ERROR: Unknown error attemtping to get server list."))) + (directory-exists? (conc areapath "/logs"))) + #f)) (let ((server-logs (glob (conc areapath "/logs/server-*.log")))) (if (null? server-logs) '() (let loop ((hed (car server-logs)) (tal (cdr server-logs)) @@ -234,142 +246,19 @@ (server:run areapath) (hash-table-set! *server-kind-run* areapath (current-seconds)))))) (define server:try-running server:run) ;; there is no more per-run servers ;; REMOVE ME. BUG. -;; (define (server:attempting-start areapath) -;; (with-output-to-file -;; (conc areapath "/.starting-server") -;; (lambda () -;; (print (current-process-id) " on " (get-host-name))))) -;; -;; (define (server:complete-attempt areapath) -;; (delete-file* (conc areapath "/.starting-server"))) -;; -;; (define (server:start-attempted? areapath) -;; (let ((flagfile (conc areapath "/.starting-server"))) -;; (handle-exceptions -;; exn -;; #f ;; if things go wrong pretend we can't see the file -;; (cond -;; ((and (file-exists? flagfile) -;; (< (- (current-seconds) -;; (file-modification-time flagfile)) -;; 15)) ;; exists and less than 15 seconds old -;; (with-input-from-file flagfile (lambda () (read-line)))) -;; ((file-exists? flagfile) ;; it is stale. -;; (server:complete-attempt areapath) -;; #f) -;; (else #f))))) -;; -;; (define (server:read-dotserver areapath) -;; (let ((dotfile (conc areapath "/.server"))) -;; (handle-exceptions -;; exn -;; #f ;; if things go wrong pretend we can't see the file -;; (cond -;; ((not (file-exists? dotfile)) -;; #f) -;; ((not (file-read-access? dotfile)) -;; #f) -;; ((> (server:dotserver-age-seconds areapath) (+ 5 (server:get-timeout))) -;; (server:remove-dotserver-file areapath ".*") -;; #f) -;; (else -;; (let* ((line -;; (with-input-from-file -;; dotfile -;; (lambda () -;; (read-line)))) -;; (tokens (if (string? line) (string-split line ":") #f))) -;; (cond -;; ((eq? 4 (length tokens)) -;; tokens) -;; (else #f)))))))) -;; -;; (define (server:read-dotserver->url areapath) -;; (let ((dotserver-tokens (server:read-dotserver areapath))) -;; (if dotserver-tokens -;; (conc (list-ref dotserver-tokens 0) ":" (list-ref dotserver-tokens 1)) -;; #f))) -;; -;; ;; write a .server file in *toppath* with hostport -;; ;; return #t on success, #f otherwise -;; ;; -;; (define (server:write-dotserver areapath host port pid transport) -;; (let ((lock-file (conc areapath "/.server.lock")) -;; (server-file (conc areapath "/.server"))) -;; (if (common:simple-file-lock lock-file) -;; (let ((res (handle-exceptions -;; exn -;; #f ;; failed for some reason, for the moment simply return #f -;; (with-output-to-file server-file -;; (lambda () -;; (print (conc host ":" port ":" pid ":" transport)))) -;; #t))) -;; (debug:print-info 0 *default-log-port* "server file " server-file " for " host ":" port " created pid="pid) -;; (common:simple-file-release-lock lock-file) -;; res) -;; #f))) -;; -;; -;; ;; this will check that the .server file present matches the server calling this procedure. -;; ;; if parameters match (this-pid and transport) the file will be touched and #t returned -;; ;; otherwise #f will be returned. -;; (define (server:confirm-dotserver areapath this-iface this-port this-pid this-transport) -;; (let* ((tokens (server:read-dotserver areapath))) -;; (cond -;; ((not tokens) -;; (debug:print-info 0 *default-log-port* "INFO: .server file does not exist.") -;; #f) -;; ((not (eq? 4 (length tokens))) -;; (debug:print-info 0 *default-log-port* "INFO: .server file is corrupt. There are not 4 tokens as expeted; there are "(length tokens)".") -;; #f) -;; ((not (equal? this-iface (list-ref tokens 0))) -;; (debug:print-info 0 *default-log-port* "INFO: .server file mismatch. for iface, server has value >"(list-ref tokens 0)"< but this server's value is >"this-iface"<") -;; #f) -;; ((not (equal? (->string this-port) (list-ref tokens 1))) -;; (debug:print-info 0 *default-log-port* "INFO: .server file mismatch. for port, .server has value >"(list-ref tokens 1)"< but this server's value is >"(->string this-port)"<") -;; #f) -;; ((not (equal? (->string this-pid) (list-ref tokens 2))) -;; (debug:print-info 0 *default-log-port* "INFO: .server file mismatch. for pid, .server has value >"(list-ref tokens 2)"< but this server's value is >"(->string this-pid)"<") -;; #f) -;; ((not (equal? (->string this-transport) (->string (list-ref tokens 3)))) -;; (debug:print-info 0 *default-log-port* "INFO: .server file mismatch. for transport, .server has value >"(list-ref tokens 3)"< but this server's value is >"this-transport"<") -;; #f) -;; (else (server:touch-dotserver areapath) -;; #t)))) -;; -;; (define (server:touch-dotserver areapath) -;; (let ((server-file (conc areapath "/.server"))) -;; (change-file-times server-file (current-seconds) (current-seconds)))) - (define (server:dotserver-age-seconds areapath) (let ((server-file (conc areapath "/.server"))) (begin (handle-exceptions exn #f (- (current-seconds) (file-modification-time server-file)))))) -;; (define (server:remove-dotserver-file areapath hostport) -;; (let ((dotserver-url (server:read-dotserver->url areapath)) -;; (server-file (conc areapath "/.server")) -;; (lock-file (conc areapath "/.server.lock"))) -;; (if (and dotserver-url (string-match (conc ".*:" hostport "$") dotserver-url)) ;; port matches, good enough info to decide to remove the file -;; (if (common:simple-file-lock lock-file) -;; (begin -;; (handle-exceptions -;; exn -;; #f -;; (delete-file* server-file)) -;; (debug:print-info 0 *default-log-port* "server file " server-file " for " hostport " removed") -;; (common:simple-file-release-lock lock-file)) -;; (debug:print-info 0 *default-log-port* "server file " server-file " for " hostport " NOT removed - could not get lock.")) -;; (debug:print-info 0 *default-log-port* "server file " server-file " for " hostport " NOT removed - dotserver-url("dotserver-url") did not match hostport pattern ("hostport")")))) - ;; no longer care if multiple servers are started by accident. older servers will drop off in time. ;; (define (server:check-if-running areapath) (let* ((servers (server:get-best (server:get-list areapath))) (best-server (if (null? servers) #f (car servers)))