Index: dashboard-main.scm
==================================================================
--- dashboard-main.scm
+++ dashboard-main.scm
@@ -50,10 +50,11 @@
;; ;; #:x 'mouse
;; ;; #:y 'mouse
;; )
))))
+
(define (mtest)
(let* ((curr-row-num 0)
(rawconfig (read-config (conc *toppath* "/megatest.config") #f 'return-string))
(keys-matrix (iup:matrix
@@ -92,11 +93,12 @@
(disks-matrix (iup:matrix
#:expand "YES"
#:numcol 1
#:numlin 20
#:numcol-visible 1
- #:numlin-visible 8)))
+ #:numlin-visible 8))
+ )
(iup:attribute-set! keys-matrix "0:0" "Field Num")
(iup:attribute-set! keys-matrix "0:1" "Field Name")
(iup:attribute-set! keys-matrix "WIDTH1" "100")
(iup:attribute-set! disks-matrix "0:0" "Disk Name")
(iup:attribute-set! disks-matrix "0:1" "Disk Path")
@@ -203,12 +205,72 @@
(define (tests)
(iup:hbox
(iup:frame #:title "Tests browser")))
(define (runs)
- (iup:hbox
- (iup:frame #:title "Runs browser")))
+ (let* ((runs-matrix (iup:matrix
+ #:expand "YES"
+ ;; #:fittosize "YES"
+ #:scrollbar "YES"
+ #:numcol 100
+ #:numlin 100
+ #:numcol-visible 7
+ #:numlin-visible 7
+ #:click-cb (lambda (obj lin col status)
+ (print "obj: " obj " lin: " lin " col: " col " status: " status)))))
+;; (iup:attribute-set! keys-matrix "0:0" "Field Num")
+;; (iup:attribute-set! keys-matrix "0:1" "Field Name")
+;; (iup:attribute-set! keys-matrix "WIDTH1" "100")
+;; (iup:attribute-set! disks-matrix "0:0" "Disk Name")
+;; (iup:attribute-set! disks-matrix "0:1" "Disk Path")
+;; (iup:attribute-set! disks-matrix "WIDTH1" "120")
+;; (iup:attribute-set! disks-matrix "WIDTH0" "100")
+;; (iup:attribute-set! disks-matrix "ALIGNMENT1" "ALEFT")
+;; (iup:attribute-set! disks-matrix "FIXTOTEXT" "C1")
+;; (iup:attribute-set! disks-matrix "RESIZEMATRIX" "YES")
+ ;; fill in keys
+;; (set! curr-row-num 1)
+;; (for-each
+;; (lambda (var)
+;; (iup:attribute-set! keys-matrix (conc curr-row-num ":0") curr-row-num)
+;; (iup:attribute-set! keys-matrix (conc curr-row-num ":1") var)
+;; (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var)))
+;; (configf:section-vars rawconfig "fields"))
+
+ ;; fill in existing info
+;; (for-each
+;; (lambda (mat fname)
+;; (set! curr-row-num 1)
+;; (for-each
+;; (lambda (var)
+;; (iup:attribute-set! mat (conc curr-row-num ":0") var)
+;; (iup:attribute-set! mat (conc curr-row-num ":1") (config-lookup rawconfig fname var))
+;; (set! curr-row-num (+ curr-row-num 1)))
+;; (configf:section-vars rawconfig fname)))
+;; (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix disks-matrix)
+;; (list "setup" "jobtools" "validvalues" "env-override" "disks"))
+
+ (for-each
+ (lambda (mat)
+ (iup:attribute-set! mat "0:1" "ubuntu\nnfs\nnone")
+ (iup:attribute-set! mat "0:0" "Test")
+ (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
+ ;; (iup:attribute-set! mat "FIXTOTEXT" "C1")
+ (iup:attribute-set! mat "RESIZEMATRIX" "YES")
+ (iup:attribute-set! mat "WIDTH1" "120")
+ (iup:attribute-set! mat "WIDTH0" "100")
+ )
+ (list runs-matrix))
+
+;; (iup:attribute-set! validvals-matrix "WIDTH1" "290")
+;; (iup:attribute-set! envovrd-matrix "WIDTH1" "290")
+
+ (iup:hbox
+ (iup:frame
+ #:title "Runs browser"
+ (iup:vbox
+ runs-matrix)))))
(define (main-panel)
(iup:dialog
#:title "Menu Test"
#:menu (main-menu)
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -99,10 +99,13 @@
;; (define *keys* (db:get-keys *db*))
(define *dbkeys* (map (lambda (x)(vector-ref x 0))
(append *keys* (list (vector "runname" "blah")))))
(define *header* #f)
(define *allruns* '())
+(define *allruns-by-id* (make-hash-table)) ;;
+(define *runchangerate* (make-hash-table))
+
(define *buttondat* (make-hash-table)) ;; <run-id color text test run-key>
(define *alltestnamelst* '())
(define *searchpatts* (make-hash-table))
(define *num-runs* 8)
(define *tot-run-count* (cdb:remote-run db:get-num-runs #f "%"))
@@ -162,15 +165,19 @@
(delta (map (lambda (a b)(abs (- a b))) c1 c2)))
(null? (filter (lambda (x)(> x 3)) delta))))
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
(define (update-rundat runnamepatt numruns testnamepatt keypatts)
- (let ((modtime (file-modification-time *db-file-path*)))
+ (let ((modtime (file-modification-time *db-file-path*))
+ (referenced-run-ids '()))
(if (or (and (> modtime *last-db-update-time*)
(> (current-seconds)(+ *last-db-update-time* 5)))
(> *delayed-update* 0))
- (begin
+ ;;
+ ;; Run this stuff only when the megatest.db file has changed
+ ;;
+ (let ((full-run (> (random 100) 75))) ;; 25% of the time do a full refresh
(debug:print-info 4 "update-rundat runnamepatt: " runnamepatt " numruns: " numruns " testnamepatt: " testnamepatt " keypatts: " keypatts)
(set! *please-update-buttons* #t)
(set! *last-db-update-time* modtime)
(set! *delayed-update* (- *delayed-update* 1))
(let* ((allruns (cdb:remote-run db:get-runs #f runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2))
@@ -184,28 +191,50 @@
;; (thread-sleep! 0.1) ;; give some time to other threads
(debug:print 6 "update-rundat, got " (length runs) " runs")
(if (> (+ *last-update* 300) (current-seconds)) ;; every five minutes
(begin
(set! *last-update* (current-seconds))
- (set! *tot-run-count* (length runs)))) ;; (rdb:get-num-runs *db* runnamepatt))))
+ (set! *tot-run-count* (length runs))))
+ ;;
+ ;; trim runs to only those that are changing often here
+
+ ;;
(for-each (lambda (run)
(let* ((run-id (db:get-value-by-header run header "id"))
(tests (let ((tsts (cdb:remote-run db:get-tests-for-run #f run-id testnamepatt states statuses)))
(if *tests-sort-reverse* (reverse tsts) tsts)))
(key-vals (cdb:remote-run db:get-key-vals #f run-id)))
+ ;; Not sure this is needed?
+ (set! referenced-run-ids (cons run-id referenced-run-ids))
(if (> (length tests) maxtests)
(set! maxtests (length tests)))
(if (or (not *hide-empty-runs*) ;; this reduces the data burden when set
(not (null? tests)))
- (set! result (cons (vector run tests key-vals) result)))))
+ (let ((dstruct (vector run tests key-vals)))
+ ;;
+ ;; compare the tests with the tests in *allruns-by-id* same run-id
+ ;; if different then increment value in *runchangerate*
+ ;;
+ (hash-table-set! *allruns-by-id* run-id dstruct)
+ (set! result (cons dstruct result))))))
runs)
+
+ ;;
+ ;; if full-run use referenced-run-ids to delete data in *all-runs-by-id* and *runchangerate*
+ ;;
+
(set! *header* header)
(set! *allruns* result)
(debug:print 6 "*allruns* has " (length *allruns*) " runs")
;; (set! *tot-run-count* (+ 1 (length *allruns*)))
maxtests))
- *num-tests*))) ;; FIXME, naughty coding eh?
+ ;;
+ ;; Run this if the megatest.db file did not get touched
+ ;;
+ (begin
+
+ *num-tests*)))) ;; FIXME, naughty coding eh?
(define *collapsed* (make-hash-table))
; (define *row-lookup* (make-hash-table)) ;; testname => (rownum lableobj)
(define (toggle-hide lnum) ; fulltestname)
Index: http-transport.scm
==================================================================
--- http-transport.scm
+++ http-transport.scm
@@ -59,13 +59,17 @@
(hostname (get-host-name))
(ipaddrstr (let ((ipstr (if (string=? "-" hostn)
(string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
#f)))
(if ipstr ipstr hostn))) ;; hostname)))
- (start-port (if (args:get-arg "-port")
+ (start-port (if (and (args:get-arg "-port")
+ (string->number (args:get-arg "-port")))
(string->number (args:get-arg "-port"))
- (+ 5000 (random 1001))))
+ (if (and (config-lookup *configdat* "server" "port")
+ (string->number (config-lookup *configdat* "server" "port")))
+ (string->number (config-lookup *configdat* "server" "port"))
+ (+ 5000 (random 1001)))))
(link-tree-path (config-lookup *configdat* "setup" "linktree")))
(set! *cache-on* #t)
(root-path (if link-tree-path
link-tree-path
(current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP!
@@ -132,17 +136,10 @@
(print "INFO: Trying to start server on " ipaddrstr ":" portnum)
;; This starts the spiffy server
(start-server port: portnum)
(print "INFO: server has been stopped")))
-(define (http-transport:mk-signature)
- (message-digest-string (md5-primitive)
- (with-output-to-string
- (lambda ()
- (write (list (current-directory)
- (argv)))))))
-
;;======================================================================
;; S E R V E R U T I L I T I E S
;;======================================================================
;;======================================================================
@@ -218,12 +215,18 @@
(loop))))))
(iface (car server-info))
(port (cadr server-info))
(last-access 0)
(tdb (tasks:open-db))
- (spid (tasks:server-get-server-id tdb #f iface port #f)))
- (print "Keep-running got server pid " spid ", using iface " iface " and port " port)
+ (spid (tasks:server-get-server-id tdb #f iface port #f))
+ (server-timeout (let ((tmo (config-lookup *configdat* "server" "timeout")))
+ (if (and (string? tmo)
+ (string->number tmo))
+ (* 60 60 (string->number tmo))
+ ;; default to three days
+ (* 3 24 60)))))
+ (debug:print-info 2 "server-timeout: " server-timeout ", server pid: " spid " on " iface ":" port)
(let loop ((count 0))
(thread-sleep! 4) ;; no need to do this very often
;; NB// sync currently does NOT return queue-length
(let () ;; (queue-len (cdb:client-call server-info 'sync #t 1)))
;; (print "Server running, count is " count)
@@ -235,16 +238,12 @@
;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access
(mutex-lock! *heartbeat-mutex*)
(set! last-access *last-db-access*)
(mutex-unlock! *heartbeat-mutex*)
- (if (> (+ last-access
- ;; (* 50 60 60) ;; 48 hrs
- ;; 60 ;; one minute
- ;; (* 60 60) ;; one hour
- (* 45 60) ;; 45 minutes, until the db deletion bug is fixed.
- )
+ ;; (debug:print 11 "last-access=" last-access ", server-timeout=" server-timeout)
+ (if (> (+ last-access server-timeout)
(current-seconds))
(begin
(debug:print-info 2 "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
(loop 0))
(begin
@@ -265,23 +264,40 @@
(debug:print 0 "ERROR: cannot find megatest.config, exiting")
(exit))))
(debug:print-info 2 "Starting the standalone server")
(let ((hostinfo (open-run-close tasks:get-best-server tasks:open-db)))
(debug:print 11 "http-transport:launch hostinfo=" hostinfo)
+ ;; #(1 "143.182.207.24" 5736 -1 "http" 22771 "hostname")
(if hostinfo
- (debug:print-info 2 "NOT starting new server, one is already running on " (car hostinfo) ":" (cadr hostinfo))
+ (debug:print-info 2 "NOT starting new server, one is already running on " (vector-ref hostinfo 1) ":" (vector-ref hostinfo 2))
(if *toppath*
(let* ((th2 (make-thread (lambda ()
(http-transport:run
(if (args:get-arg "-server")
(args:get-arg "-server")
"-"))) "Server run"))
- (th3 (make-thread (lambda ()(http-transport:keep-running)) "Keep running"))
- )
+ (th3 (make-thread (lambda ()(http-transport:keep-running)) "Keep running")))
(thread-start! th2)
(thread-start! th3)
(set! *didsomething* #t)
- (thread-join! th2)
- )
+ (thread-join! th2))
(debug:print 0 "ERROR: Failed to setup for megatest")))
(exit)))
+(define (http-transport:server-signal-handler signum)
+ (handle-exceptions
+ exn
+ (debug:print " ... exiting ...")
+ (let ((th1 (make-thread (lambda ()
+ (thread-sleep! 1))
+ ;; (if (not *received-response*)
+ ;; (receive-message* *runremote*))) ;; flush out last call if applicable
+ "eat response"))
+ (th2 (make-thread (lambda ()
+ (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.")
+ (thread-sleep! 3) ;; give the flush three seconds to do it's stuff
+ (debug:print 0 " Done.")
+ (exit 4))
+ "exit on ^C timer")))
+ (thread-start! th2)
+ (thread-start! th1)
+ (thread-join! th2))))
DELETED rpc-transport.scm
Index: rpc-transport.scm
==================================================================
--- rpc-transport.scm
+++ /dev/null
@@ -1,381 +0,0 @@
-
-;; Copyright 2006-2012, Matthew Welland.
-;;
-;; This program is made available under the GNU GPL version 2.0 or
-;; greater. See the accompanying file COPYING for details.
-;;
-;; This program is distributed WITHOUT ANY WARRANTY; without even the
-;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
-;; PURPOSE.
-
-(require-extension (srfi 18) extras tcp s11n)
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
-(import (prefix sqlite3 sqlite3:))
-
-(use spiffy uri-common intarweb http-client spiffy-request-vars)
-
-(tcp-buffer-size 2048)
-
-(declare (unit server))
-
-(declare (uses common))
-(declare (uses db))
-(declare (uses tests))
-(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
-
-(include "common_records.scm")
-(include "db_records.scm")
-
-(define (rpc-server:make-server-url hostport)
- (if (not hostport)
- #f
- (conc "http://" (car hostport) ":" (cadr hostport))))
-
-(define *server-loop-heart-beat* (current-seconds))
-(define *heartbeat-mutex* (make-mutex))
-
-;;======================================================================
-;; S E R V E R
-;;======================================================================
-
-;; Call this to start the actual server
-;;
-
-(define *db:process-queue-mutex* (make-mutex))
-
-(define (rpc-server:run hostn)
- (debug:print 2 "Attempting to start the server ...")
- (if (not *toppath*)
- (if (not (setup-for-run))
- (begin
- (debug:print 0 "ERROR: cannot find megatest.config, cannot start server, exiting")
- (exit))))
- (let* (;; (iface (if (string=? "-" hostn)
- ;; #f ;; (get-host-name)
- ;; hostn))
- (db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily
- (hostname (get-host-name))
- (ipaddrstr (let ((ipstr (if (string=? "-" hostn)
- (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
- #f)))
- (if ipstr ipstr hostn))) ;; hostname)))
- (start-port (if (args:get-arg "-port")
- (string->number (args:get-arg "-port"))
- (+ 5000 (random 1001))))
- (link-tree-path (config-lookup *configdat* "setup" "linktree")))
- (set! *cache-on* #t)
- (root-path (if link-tree-path
- link-tree-path
- (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP!
-
- ;; Setup the web server and a /ctrl interface
- ;;
- (vhost-map `(((* any) . ,(lambda (continue)
- ;; open the db on the first call
- (if (not db)(set! db (open-db)))
- (let* (($ (request-vars source: 'both))
- (dat ($ 'dat))
- (res #f))
- (cond
- ((equal? (uri-path (request-uri (current-request)))
- '(/ "hey"))
- (send-response body: "hey there!\n"
- headers: '((content-type text/plain))))
- ;; This is the /ctrl path where data is handed to the server and
- ;; responses
- ((equal? (uri-path (request-uri (current-request)))
- '(/ "ctrl"))
- (let* ((packet (db:string->obj dat))
- (qtype (cdb:packet-get-qtype packet)))
- (debug:print-info 12 "server=> received packet=" packet)
- (if (not (member qtype '(sync ping)))
- (begin
- (mutex-lock! *heartbeat-mutex*)
- (set! *last-db-access* (current-seconds))
- (mutex-unlock! *heartbeat-mutex*)))
- ;; (mutex-lock! *db:process-queue-mutex*) ;; trying a mutex
- ;; (set! res (open-run-close db:process-queue-item open-db packet))
- (set! res (db:process-queue-item db packet))
- ;; (mutex-unlock! *db:process-queue-mutex*)
- (debug:print-info 11 "Return value from db:process-queue-item is " res)
- (send-response body: (conc "<head>ctrl data</head>\n<body>"
- res
- "</body>")
- headers: '((content-type text/plain)))))
- (else (continue))))))))
- (server:try-start-server ipaddrstr start-port)
- ;; lite3:finalize! db)))
- ))
-
-
-
-;; (define (rpc-server:main-loop)
-;; (print "INFO: Exectuing main server loop")
-;; (access-log "megatest-http.log")
-;; (server-bind-address #f)
-;; (define-page (main-page-path)
-;; (lambda ()
-;; (let ((dat ($ "dat")))
-;; ;; (with-request-variables (dat)
-;; (debug:print-info 12 "Got dat=" dat)
-;; (let* ((packet (db:string->obj dat))
-;; (qtype (cdb:packet-get-qtype packet)))
-;; (debug:print-info 12 "server=> received packet=" packet)
-;; (if (not (member qtype '(sync ping)))
-;; (begin
-;; (mutex-lock! *heartbeat-mutex*)
-;; (set! *last-db-access* (current-seconds))
-;; (mutex-unlock! *heartbeat-mutex*)))
-;; (let ((res (open-run-close db:process-queue-item open-db packet)))
-;; (debug:print-info 11 "Return value from db:process-queue-item is " res)
-;; res))))))
-
-;;; (use spiffy uri-common intarweb)
-;;;
-;;; (root-path "/var/www")
-;;;
-;;; (vhost-map `(((* any) . ,(lambda (continue)
-;;; (if (equal? (uri-path (request-uri (current-request)))
-;;; '(/ "hey"))
-;;; (send-response body: "hey there!\n"
-;;; headers: '((content-type text/plain)))
-;;; (continue))))))
-;;;
-;;; (start-server port: 12345)
-
-;; This is recursively run by server:run until sucessful
-;;
-(define (rpc-server:try-start-server ipaddrstr portnum)
- (handle-exceptions
- exn
- (begin
- (print-error-message exn)
- (if (< portnum 9000)
- (begin
- (print "WARNING: failed to start on portnum: " portnum ", trying next port")
- (thread-sleep! 0.1)
- (open-run-close tasks:remove-server-records tasks:open-db)
- (server:try-start-server ipaddrstr (+ portnum 1)))
- (print "ERROR: Tried and tried but could not start the server")))
- (set! *runremote* (list ipaddrstr portnum))
- (open-run-close tasks:remove-server-records tasks:open-db)
- (open-run-close tasks:server-register
- tasks:open-db
- (current-process-id)
- ipaddrstr portnum 0 'live)
- (print "INFO: Trying to start server on " ipaddrstr ":" portnum)
- ;; This starts the spiffy server
- (start-server port: portnum)
- (print "INFO: server has been stopped")))
-
-(define (rpc-server:mk-signature)
- (message-digest-string (md5-primitive)
- (with-output-to-string
- (lambda ()
- (write (list (current-directory)
- (argv)))))))
-
-;;======================================================================
-;; S E R V E R U T I L I T I E S
-;;======================================================================
-
-;; When using zmq this would send the message back (two step process)
-;; with spiffy or rpc this simply returns the return data to be returned
-;;
-(define (rpc-server:reply return-addr query-sig success/fail result)
- (debug:print-info 11 "server:reply return-addr=" return-addr ", result=" result)
- ;; (send-message pubsock target send-more: #t)
- ;; (send-message pubsock
- (db:obj->string (vector success/fail query-sig result)))
-
-;;======================================================================
-;; C L I E N T S
-;;======================================================================
-
-;; <html>
-;; <head></head>
-;; <body>1 Hello, world! Goodbye Dolly</body></html>
-;; Send msg to serverdat and receive result
-(define (rpc-server:client-send-receive serverdat msg)
- (let* ((url (server:make-server-url serverdat))
- (fullurl (conc url "/ctrl")) ;; (conc url "/?dat=" msg)))
- (numretries 0))
- (handle-exceptions
- exn
- (if (< numretries 200)
- (server:client-send-receive serverdat msg))
- (begin
- (debug:print-info 11 "fullurl=" fullurl "\n")
- ;; set up the http-client here
- (max-retry-attempts 100)
- (retry-request? (lambda (request)
- (thread-sleep! (/ (if (> numretries 100) 100 numretries) 10))
- (set! numretries (+ numretries 1))
- #t))
- ;; send the data and get the response
- ;; extract the needed info from the http data and
- ;; process and return it.
- (let* ((res (with-input-from-request fullurl
- ;; #f
- ;; msg
- (list (cons 'dat msg))
- read-string)))
- (debug:print-info 11 "got res=" res)
- (let ((match (string-search (regexp "<body>(.*)<.body>") res)))
- (debug:print-info 11 "match=" match)
- (let ((final (cadr match)))
- (debug:print-info 11 "final=" final)
- final)))))))
-
-(define (client:login serverdat serverdat)
- (max-retry-attempts 100)
- (cdb:login serverdat *toppath* (client:get-signature)))
-
-;; Not currently used! But, I think it *should* be used!!!
-(define (client:logout serverdat)
- (let ((ok (and (socket? serverdat)
- (cdb:logout serverdat *toppath* (client:get-signature)))))
- ;; (close-socket serverdat)
- ok))
-
-(define (rpc-server:client-connect iface port)
- (let* ((login-res #f)
- (serverdat (list iface port)))
- (set! login-res (client:login serverdat serverdat))
- (if (and (not (null? login-res))
- (car login-res))
- (begin
- (debug:print-info 2 "Logged in and connected to " iface ":" port)
- (set! *runremote* serverdat)
- serverdat)
- (begin
- (debug:print-info 2 "Failed to login or connect to " iface ":" port)
- (set! *runremote* #f)
- #f))))
-
-;; Do all the connection work, start a server if not already running
-(define (client:setup #!key (numtries 50))
- (if (not *toppath*)
- (if (not (setup-for-run))
- (begin
- (debug:print 0 "ERROR: failed to find megatest.config, exiting")
- (exit))))
- (let ((hostinfo (open-run-close tasks:get-best-server tasks:open-db)))
- (if hostinfo
- (let ((host (list-ref hostinfo 0))
- (iface (list-ref hostinfo 1))
- (port (list-ref hostinfo 2))
- (pid (list-ref hostinfo 3)))
- (debug:print-info 2 "Setting up to connect to " hostinfo)
- (server:client-connect iface port)) ;; )
- (if (> numtries 0)
- (let ((exe (car (argv)))
- (pid #f))
- (debug:print-info 0 "No server available, attempting to start one...")
- (set! pid (process-run exe (list "-server" "-" "-debug" (if (list? *verbosity*)
- (string-intersperse *verbosity* ",")
- (conc *verbosity*)))))
- ;; (set! pid (process-fork (lambda ()
- ;; (current-input-port (open-input-file "/dev/null"))
- ;; (current-output-port (open-output-file "/dev/null"))
- ;; (current-error-port (open-output-file "/dev/null"))
- ;; (server:launch))))
- (let loop ((count 0))
- (let ((hostinfo (open-run-close tasks:get-best-server tasks:open-db)))
- (if (not hostinfo)
- (begin
- (debug:print-info 0 "Waiting for server pid=" pid " to start")
- (sleep 2) ;; give server time to start
- (if (< count 5)
- (loop (+ count 1)))))))
- ;; we are starting a server, do not try again! That can lead to
- ;; recursively starting many processes!!!
- (client:setup numtries: 0))
- (debug:print-info 1 "Too many attempts, giving up")))))
-
-;; 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 (rpc-server:keep-running)
- ;; if none running or if > 20 seconds since
- ;; server last used then start shutdown
- ;; This thread waits for the server to come alive
- (let* ((server-info (let loop ()
- (let ((sdat #f))
- (mutex-lock! *heartbeat-mutex*)
- (set! sdat *runremote*)
- (mutex-unlock! *heartbeat-mutex*)
- (if sdat sdat
- (begin
- (sleep 4)
- (loop))))))
- (iface (car server-info))
- (port (cadr server-info))
- (last-access 0)
- (tdb (tasks:open-db))
- (spid (tasks:server-get-server-id tdb #f iface port #f)))
- (print "Keep-running got server pid " spid ", using iface " iface " and port " port)
- (let loop ((count 0))
- (thread-sleep! 4) ;; no need to do this very often
- ;; NB// sync currently does NOT return queue-length
- (let () ;; (queue-len (cdb:client-call server-info 'sync #t 1)))
- ;; (print "Server running, count is " count)
- (if (< count 1) ;; 3x3 = 9 secs aprox
- (loop (+ count 1)))
-
- ;; NOTE: Get rid of this mechanism! It really is not needed...
- (tasks:server-update-heartbeat tdb spid)
-
- ;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access
- (mutex-lock! *heartbeat-mutex*)
- (set! last-access *last-db-access*)
- (mutex-unlock! *heartbeat-mutex*)
- (if (> (+ last-access
- ;; (* 50 60 60) ;; 48 hrs
- ;; 60 ;; one minute
- ;; (* 60 60) ;; one hour
- (* 45 60) ;; 45 minutes, until the db deletion bug is fixed.
- )
- (current-seconds))
- (begin
- (debug:print-info 2 "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
- (loop 0))
- (begin
- (debug:print-info 0 "Starting to shutdown the server.")
- ;; need to delete only *my* server entry (future use)
- (set! *time-to-exit* #t)
- (tasks:server-deregister-self tdb (get-host-name))
- (thread-sleep! 1)
- (debug:print-info 0 "Max cached queries was " *max-cache-size*)
- (debug:print-info 0 "Server shutdown complete. Exiting")
- (exit)))))))
-
-;; all routes though here end in exit ...
-(define (rpc-server:launch)
- (if (not *toppath*)
- (if (not (setup-for-run))
- (begin
- (debug:print 0 "ERROR: cannot find megatest.config, exiting")
- (exit))))
- (debug:print-info 2 "Starting the standalone server")
- (let ((hostinfo (open-run-close tasks:get-best-server tasks:open-db)))
- (debug:print 11 "server:launch hostinfo=" hostinfo)
- (if hostinfo
- (debug:print-info 2 "NOT starting new server, one is already running on " (car hostinfo) ":" (cadr hostinfo))
- (if *toppath*
- (let* ((th2 (make-thread (lambda ()
- (server:run
- (if (args:get-arg "-server")
- (args:get-arg "-server")
- "-"))) "Server run"))
- (th3 (make-thread (lambda ()(server:keep-running)) "Keep running"))
- )
- (thread-start! th2)
- (thread-start! th3)
- (set! *didsomething* #t)
- (thread-join! th2)
- )
- (debug:print 0 "ERROR: Failed to setup for megatest")))
- (exit)))
-
Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -40,74 +40,26 @@
;; Call this to start the actual server
;;
(define *db:process-queue-mutex* (make-mutex))
-(define (server:run hostn)
- (debug:print 2 "Attempting to start the server ...")
+;; all routes though here end in exit ...
+(define (server:launch transport)
(if (not *toppath*)
(if (not (setup-for-run))
(begin
- (debug:print 0 "ERROR: cannot find megatest.config, cannot start server, exiting")
+ (debug:print 0 "ERROR: cannot find megatest.config, exiting")
(exit))))
- (let* (;; (iface (if (string=? "-" hostn)
- ;; #f ;; (get-host-name)
- ;; hostn))
- (db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily
- (hostname (get-host-name))
- (ipaddrstr (let ((ipstr (if (string=? "-" hostn)
- (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
- #f)))
- (if ipstr ipstr hostn))) ;; hostname)))
- (start-port (if (args:get-arg "-port")
- (string->number (args:get-arg "-port"))
- (+ 5000 (random 1001))))
- (link-tree-path (config-lookup *configdat* "setup" "linktree")))
- (set! *cache-on* #t)
- (root-path (if link-tree-path
- link-tree-path
- (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP!
-
- ;; Setup the web server and a /ctrl interface
- ;;
- (vhost-map `(((* any) . ,(lambda (continue)
- ;; open the db on the first call
- (if (not db)(set! db (open-db)))
- (let* (($ (request-vars source: 'both))
- (dat ($ 'dat))
- (res #f))
- (cond
- ((equal? (uri-path (request-uri (current-request)))
- '(/ "hey"))
- (send-response body: "hey there!\n"
- headers: '((content-type text/plain))))
- ;; This is the /ctrl path where data is handed to the server and
- ;; responses
- ((equal? (uri-path (request-uri (current-request)))
- '(/ "ctrl"))
- (let* ((packet (db:string->obj dat))
- (qtype (cdb:packet-get-qtype packet)))
- (debug:print-info 12 "server=> received packet=" packet)
- (if (not (member qtype '(sync ping)))
- (begin
- (mutex-lock! *heartbeat-mutex*)
- (set! *last-db-access* (current-seconds))
- (mutex-unlock! *heartbeat-mutex*)))
- ;; (mutex-lock! *db:process-queue-mutex*) ;; trying a mutex
- ;; (set! res (open-run-close db:process-queue-item open-db packet))
- (set! res (db:process-queue-item db packet))
- ;; (mutex-unlock! *db:process-queue-mutex*)
- (debug:print-info 11 "Return value from db:process-queue-item is " res)
- (send-response body: (conc "<head>ctrl data</head>\n<body>"
- res
- "</body>")
- headers: '((content-type text/plain)))))
- (else (continue))))))))
- (server:try-start-server ipaddrstr start-port)
- ;; lite3:finalize! db)))
- ))
-
+ (debug:print-info 2 "Starting server using " transport " transport")
+ (set! *transport-type* transport)
+ (case transport
+ ((fs) (exit)) ;; there is no "fs" transport
+ ((http) (http-transport:launch))
+ ((zmq) (zmq-transport:launch))
+ (else
+ (debug:print "WARNING: unrecognised transport " transport)
+ (exit))))
(define (server:mk-signature)
(message-digest-string (md5-primitive)
(with-output-to-string
(lambda ()
@@ -134,24 +86,5 @@
(send-message pub-socket (db:obj->string (vector success/fail query-sig result)))))
(else
(debug:print 0 "ERROR: unrecognised transport type: " *transport-type*)
result)))
-
-
-;; all routes though here end in exit ...
-(define (server:launch transport)
- (if (not *toppath*)
- (if (not (setup-for-run))
- (begin
- (debug:print 0 "ERROR: cannot find megatest.config, exiting")
- (exit))))
- (debug:print-info 2 "Starting server using " transport " transport")
- (set! *transport-type* transport)
- (case transport
- ((fs) (exit)) ;; there is no "fs" transport
- ((http) (http-transport:launch))
- ((zmq) (zmq-transport:launch))
- (else
- (debug:print "WARNING: unrecognised transport " transport)
- (exit))))
-
Index: tasks.scm
==================================================================
--- tasks.scm
+++ tasks.scm
@@ -192,15 +192,17 @@
(let ((res '())
(best #f))
(sqlite3:for-each-row
(lambda (id interface port pubport transport pid hostname)
(set! res (cons (vector id interface port pubport transport pid hostname) res))
- (debug:print-info 2 "Found existing server " hostname ":" port " registered in db"))
+ ;;(debug:print-info 2 "Found existing server " hostname ":" port " registered in db"))
+ )
mdb
- ;; strftime('%s','now')-heartbeat < 10 AND
+
"SELECT id,interface,port,pubport,transport,pid,hostname FROM servers
- WHERE mt_version=? ORDER BY start_time DESC LIMIT 1;" megatest-version)
+ WHERE strftime('%s','now')-heartbeat < 10
+ AND mt_version=? ORDER BY start_time DESC LIMIT 1;" megatest-version)
;; for now we are keeping only one server registered in the db, return #f or first server found
(if (null? res) #f (car res))))
;; BUG: This logic is probably needed unless methodology changes completely...
;;
Index: tests/Makefile
==================================================================
--- tests/Makefile
+++ tests/Makefile
@@ -19,10 +19,11 @@
TARGET = "-target ubuntu/nfs/none"
all : test1 test2 test3 test4 test5
server :
+ (cd ..;make install) && \
(cd fullrun;../../bin/megatest -server - -debug 22) &
test0 : cleanprep
cd simplerun ; $(MEGATEST) -server - -debug $(DEBUG)&
Index: tests/fullrun/config/mt_include_1.config
==================================================================
--- tests/fullrun/config/mt_include_1.config
+++ tests/fullrun/config/mt_include_1.config
@@ -1,8 +1,9 @@
[setup]
# exectutable /path/to/megatest
-max_concurrent_jobs 60
+max_concurrent_jobs 200
+
linktree #{getenv MT_RUN_AREA_HOME}/tmp/mt_links
[jobtools]
useshell yes
# ## launcher launches jobs, the job is managed on the target host
Index: tests/fullrun/megatest.config
==================================================================
--- tests/fullrun/megatest.config
+++ tests/fullrun/megatest.config
@@ -42,10 +42,20 @@
EMPTY_VAR
# XTERM [system xterm]
# RUNDEAD [system exit 56]
+[server]
+
+# If the server can't be started on this port it will try the next port until
+# it succeeds
+port 8090
+
+# This server will keep running this number of hours after last access.
+# Three minutes is 0.05 hours
+timeout 0.05
+
## disks are:
## name host:/path/to/area
## -or-
## name /path/to/area
[disks]