Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1120,20 +1120,22 @@ (if (and (> (length remparam) 1) (eq? *toppath* (car remparam)) (hash-table-ref/default *logged-in-clients* (cadr remparam) #f)) #t #f)) + ((numclients) + (length (hash-table-keys *logged-in-clients*))) ((flush) (db:write-cached-data) #t) ((immediate) (db:write-cached-data) (if (not (null? remparam)) (apply (car remparam) (cdr remparam)) "ERROR")) ((killserver) - (db:write-cached-data) + ;; (db:write-cached-data) (debug:print-info 0 "Remotely killed server on host " (get-host-name) " pid " (current-process-id)) (set! *time-to-exit* #t) #t) ((set-verbosity) (set! *verbosity* (caddr params)) @@ -1179,10 +1181,13 @@ (cdb:client-call zmq-socket 'login #t keyval signature)) (define (cdb:logout zmq-socket keyval signature) (cdb:client-call zmq-socket 'logout #t keyval signature)) +(define (cdb:num-clients zmq-socket) + (cdb:client-call zmq-socket 'numclients #t)) + (define (cdb:test-set-status-state zmqsocket test-id status state msg) (if msg (cdb:client-call zmqsocket 'state-status-msg #t state status msg test-id) (cdb:client-call zmqsocket 'state-status #t state status test-id))) ;; run-id test-name item-path minutes cpuload diskfree tmpfree) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -96,11 +96,11 @@ -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are overwritten by values set in config files. -server -|hostname : start the server (reduces contention on megatest.db), use - to automatically figure out hostname -listservers : list the servers - -killserver host:port|pid : kill server specified by host:port or pid, use % to kill all + -killserver host:port|pid : kill server specified by host:port or pid -repl : start a repl (useful for extending megatest) Spreadsheet generation -extract-ods fname.ods : extract an open document spreadsheet from the database -pathmod path : insert path, i.e. path/runame/itempath/logfile.html @@ -272,38 +272,59 @@ (if (or (args:get-arg "-listservers") (args:get-arg "-killserver")) (let ((tl (setup-for-run))) (if tl (let ((servers (open-run-close tasks:get-all-servers tasks:open-db)) - (fmtstr "~5a~8a~20a~5a~20a~9a~10a\n")) - (format #t fmtstr "Id" "Pid" "Host" "Port" "Time" "Priority" "State") - (format #t fmtstr "==" "===" "====" "====" "====" "========" "=====") + (fmtstr "~5a~8a~20a~5a~20a~9a~20a~5a\n") + (servers-to-kill '())) + (format #t fmtstr "Id" "Pid" "Host" "Port" "Time" "Priority" "State" "Num Clients") + (format #t fmtstr "==" "===" "====" "====" "====" "========" "=====" "===========") (for-each (lambda (server) - (let* ((id (vector-ref server 0)) + (let* ((killinfo (args:get-arg "-killserver")) + (khost-port (if killinfo (if (substring-index ":" killinfo)(string-split ":") #f) #f)) + (kpid (if killinfo (if (substring-index ":" killinfo) #f (string->number killinfo)) #f)) + (id (vector-ref server 0)) (pid (vector-ref server 1)) (hostname (vector-ref server 2)) (port (vector-ref server 3)) (start-time (vector-ref server 4)) (priority (vector-ref server 5)) (state (vector-ref server 6)) - (status (handle-exceptions - exn - (conc "EXCEPTION: " ((condition-property-accessor 'exn 'message) exn)) + (numclients #f) + (stat-numc ;; (handle-exceptions + ;; exn + ;; (list #f (conc "EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))) (let ((zmq-socket (server:client-connect hostname port))) (if zmq-socket (if (server:client-login zmq-socket) - (begin - (server:client-logout zmq-socket) + (let ((numclients (cdb:num-clients zmq-socket)) + (killed #f)) + (if (and khost-port ;; kill by host/port + (equal? hostname (car khost-port)) + (equal? port (string->number (cadr khost-port)))) + (begin + (open-run-close tasks:server-deregister tasks:open-db hostname port: port) + (cdb:kill-server zmq-socket) + (debug:print-info 1 "Killed server by host:port at " hostname ":" port) + (set! killed #t)) + (if (and kpid + (equal? kpid pid)) + (begin + (open-run-close tasks:server-deregister tasks:open-db hostname pid: pid) + (set! killed #t) + (cdb:kill-server zmq-socket) + (debug:print-info 1 "Killed server by pid at " hostname ":" port)))) + (if (not killed)(server:client-logout zmq-socket)) (close-socket zmq-socket) - "ACCESSIBLE") ;; (server:client-logout zmq-socket) + (list numclients "ACCESSIBLE")) ;; (server:client-logout zmq-socket) (begin (close-socket zmq-socket) - "CAN'T LOGIN")) - "CAN'T CONNECT"))))) + (list #f "CAN'T LOGIN"))) + (list #f "CAN'T CONNECT"))))) ;; ) (format #t fmtstr id pid hostname port start-time priority - status))) + (cadr stat-numc)(car stat-numc)))) servers) (set! *didsomething* #t)))) ;; if not list or kill then start a client (if appropriate) (if (or (let ((res #f)) (for-each Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -67,12 +67,17 @@ (res #f)) (debug:print-info 12 "server=> received params=" params) (set! res (cdb:cached-access params)) (debug:print-info 12 "server=> processed res=" res) (send-message zmq-socket (db:obj->string res)) - (if *time-to-exit* (exit)) - (loop))))) + (if (not *time-to-exit*) + (loop) + (begin + (db:write-cached-data) + (open-run-close tasks:server-deregister-self tasks:open-db) + (exit) + )))))) ;; run server:keep-running in a parallel thread to monitor that the db is being ;; used and to shutdown after sometime if it is not. ;; (define (server:keep-running) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -79,10 +79,11 @@ mdb "INSERT OR REPLACE INTO servers (pid,hostname,port,start_time,priority,state) VALUES(?,?,?,strftime('%s','now'),?,?);" pid hostname port priority (conc state))) (define (tasks:server-deregister mdb hostname #!key (port #f)(pid #f)) + (debug:print-info 11 "server-deregister " hostname ", port " port ", pid " pid) (if pid (sqlite3:execute mdb "DELETE FROM servers WHERE hostname=? AND pid=?;" hostname pid) (if port (sqlite3:execute mdb "DELETE FROM servers WHERE hostname=? AND port=?;" hostname port) (debug:print 0 "ERROR: tasks:server-deregister called with neither pid nor port specified"))))