Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -76,10 +76,11 @@
(begin
(print "Failed to find megatest.config, exiting")
(exit 1)))
(define *db* (open-db))
+(server:client-setup *db*)
(define toplevel #f)
(define dlg #f)
(define max-test-num 0)
(define *keys* (rdb:get-keys *db*))
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -35,12 +35,10 @@
(db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath))
(handler (make-busy-timeout 36000)))
(sqlite3:set-busy-handler! db handler)
(if (not dbexists)
(db:initialize db))
- (if (not (args:get-arg "-server"))
- (server:client-setup db))
db))
(define (db:initialize db)
(let* ((configdat (car *configinfo*)) ;; tut tut, global warning...
(keys (config-get-fields configdat))
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -90,10 +90,12 @@
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
;; now can find our db
(set! db (open-db))
+ (if (not (args:get-arg "-server"))
+ (server:client-setup db))
(set-megatest-env-vars db run-id) ;; these may be needed by the launching process
(change-directory work-area)
(set-run-config-vars db run-id)
;; environment overrides are done *before* the remaining critical envars.
(alist->env-vars env-ovrd)
@@ -146,10 +148,12 @@
;; do all the ezsteps (if any)
(if ezsteps
(let* ((testconfig (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here?
(ezstepslst (hash-table-ref/default testconfig "ezsteps" '()))
(db (open-db)))
+ (if (not (args:get-arg "-server"))
+ (server:client-setup db))
(if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps"))
;; if ezsteps was defined then we are sure to have at least one step but check anyway
(if (not (> (length ezstepslst) 0))
(debug:print 0 "ERROR: ezsteps defined but ezstepslst is zero length")
(let loop ((ezstep (car ezstepslst))
@@ -244,10 +248,12 @@
(let loop ((minutes (calc-minutes)))
(let* ((db (open-db))
(cpuload (get-cpu-load))
(diskfree (get-df (current-directory)))
(tmpfree (get-df "/tmp")))
+ (if (not (args:get-arg "-server"))
+ (server:client-setup db))
(if (not cpuload) (begin (debug:print 0 "WARNING: CPULOAD not found.") (set! cpuload "n/a")))
(if (not diskfree) (begin (debug:print 0 "WARNING: DISKFREE not found.") (set! diskfree "n/a")))
(set! kill-job? (test-get-kill-request db run-id test-name itemdat))
(rdb:test-update-meta-info db run-id test-name itemdat minutes cpuload diskfree tmpfree)
(if kill-job?
@@ -287,10 +293,12 @@
(thread-start! th1)
(thread-start! th2)
(thread-join! th2)
(mutex-lock! m)
(set! db (open-db))
+ (if (not (args:get-arg "-server"))
+ (server:client-setup db))
(let* ((item-path (item-list->path itemdat))
(testinfo (db:get-test-info db run-id test-name item-path)))
(if (not (equal? (db:test-get-state testinfo) "COMPLETED"))
(begin
(debug:print 2 "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status)
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -240,10 +240,12 @@
(if (not (setup-for-run))
(begin
(debug:print 0 print "Failed to setup, exiting")
(exit 1)))
(set! db (open-db))
+ (if (not (args:get-arg "-server"))
+ (server:client-setup db))
(if (not (car *configinfo*))
(begin
(debug:print 0 "ERROR: Attempted to remove test(s) but run area config file not found")
(exit 1))
;; put test parameters into convenient variables
@@ -275,10 +277,12 @@
(runsdat (rdb:get-runs db runpatt #f #f '()))
(runs (db:get-rows runsdat))
(header (db:get-header runsdat))
(keys (rdb:get-keys db))
(keynames (map key:get-fieldname keys)))
+ (if (not (args:get-arg "-server"))
+ (server:client-setup db))
;; Each run
(for-each
(lambda (run)
(debug:print 2 "Run: "
(string-intersperse (map (lambda (x)
@@ -440,10 +444,12 @@
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, giving up on -test-paths, exiting")
(exit 1)))
(set! db (open-db))
+ (if (not (args:get-arg "-server"))
+ (server:client-setup db))
(let* ((itempatt (args:get-arg "-itempatt"))
(keys (rdb:get-keys db))
(keynames (map key:get-fieldname keys))
(paths (db:test-get-paths-matching db keynames target)))
(set! *didsomething* #t)
@@ -487,11 +493,13 @@
(exit 1)))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, giving up on -archive, exiting")
(exit 1)))
- (set! db (open-db))
+ (set! db (open-db))
+ (if (not (args:get-arg "-server"))
+ (server:client-setup db))
(let* ((itempatt (args:get-arg "-itempatt"))
(keys (rdb:get-keys db))
(keynames (map key:get-fieldname keys))
(paths (db:test-get-paths-matching db keynames target)))
(set! *didsomething* #t)
@@ -559,10 +567,12 @@
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(set! db (open-db))
+ (if (not (args:get-arg "-server"))
+ (server:client-setup db))
(if (and state status)
(rdb:teststep-set-status! db run-id test-name step state status itemdat (args:get-arg "-m") logfile)
(begin
(debug:print 0 "ERROR: You must specify :state and :status with every call to -step")
(exit 6)))
@@ -595,10 +605,12 @@
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(set! db (open-db))
+ (if (not (args:get-arg "-server"))
+ (server:client-setup db))
(if (args:get-arg "-load-test-data")
(db:load-test-data db run-id test-name itemdat))
(if (args:get-arg "-setlog")
(test-set-log! db run-id test-name itemdat (args:get-arg "-setlog")))
(if (args:get-arg "-set-toplog")
@@ -633,11 +645,13 @@
(change-directory startingdir)
(set! exitstat (system fullcmd)) ;; cmd params))
(set! *globalexitstatus* exitstat)
(change-directory testpath)
;; re-open the db
- (set! db (open-db))
+ (set! db (open-db))
+ (if (not (args:get-arg "-server"))
+ (server:client-setup db))
;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log"))
(if logprofile
(let* ((htmllogfile (conc stepname ".html"))
(oldexitstat exitstat)
(cmd (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " ")))
@@ -686,10 +700,12 @@
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(set! db (open-db))
+ (if (not (args:get-arg "-server"))
+ (server:client-setup db))
(set! keys (rdb:get-keys db))
(debug:print 1 "Keys: " (string-intersperse (map key:get-fieldname keys) ", "))
(sqlite3:finalize! db)
(set! *didsomething* #t)))
@@ -725,10 +741,12 @@
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
;; now can find our db
(set! db (open-db))
+ (if (not (args:get-arg "-server"))
+ (server:client-setup db))
(runs:update-all-test_meta db)
(sqlite3:finalize! db)
(set! *didsomething* #t)))
;;======================================================================
@@ -738,17 +756,20 @@
(let* ((toppath (setup-for-run))
(db (if toppath (open-db) #f)))
(if db
(begin
(set! *db* db)
+ (if (not (args:get-arg "-server"))
+ (server:client-setup db))
(import readline)
(import apropos)
(gnu-history-install-file-manager
(string-append
(or (get-environment-variable "HOME") ".") "/.megatest_history"))
(current-input-port (make-gnu-readline-port "megatest> "))
- (repl)))))
+ (repl)))
+ (set! *didsomething* #t)))
;;======================================================================
;; Exit and clean up
;;======================================================================
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -402,11 +402,11 @@
(testdat (rdb:get-test-info db run-id test-name item-path)))
(if (not testdat)
(begin
;; ensure that the path exists before registering the test
(system (conc "mkdir -p " new-test-path))
- (register-test db run-id test-name item-path)
+ (rtests:register-test db run-id test-name item-path)
(set! testdat (rdb:get-test-info db run-id test-name item-path))))
(change-directory test-path)
(case (if force ;; (args:get-arg "-force")
'NOT_STARTED
(if testdat
@@ -582,10 +582,12 @@
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(set! db (open-db))
+ (if (not (args:get-arg "-server"))
+ (server:client-setup db))
(set! keys (rdb:get-keys db))
;; have enough to process -target or -reqtarg here
(if (args:get-arg "-reqtarg")
(let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL
(runconfig (read-config runconfigf #f #f environ-patt: #f)))
Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -16,10 +16,11 @@
(declare (unit server))
(declare (uses common))
(declare (uses db))
+(declare (uses tests))
(include "common_records.scm")
(include "db_records.scm")
;; procstr is the name of the procedure to be called as a string
@@ -185,10 +186,15 @@
(rpc:publish-procedure!
'rdb:delete-test-records
(lambda (test-id)
(db:delete-test-records db test-id)))
+ (rpc:publish-procedure!
+ 'rtests:register-test
+ (lambda (run-id test-name item-path)
+ (tests:register-test db run-id test-name item-path)))
+
(set! *rpc:listener* rpc:listener)
(on-exit (lambda ()
(sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER' and val=?;" host:port)
(sqlite3:finalize! db)))
(thread-start! th1)
@@ -202,28 +208,30 @@
(server:find-free-port-and-open (+ port 1)))
(rpc:default-server-port port)
(tcp-listen (rpc:default-server-port))))
(define (server:client-setup db)
- (let* ((hostinfo (db:get-var db "SERVER"))
- (hostdat (if hostinfo (string-split hostinfo ":")))
- (host (if hostinfo (car hostdat)))
- (port (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) #f)))
- (if (and port
- (string->number port))
- (let ((portn (string->number port)))
- (debug:print 2 "INFO: Setting up to connect to host " host ":" port)
- (handle-exceptions
- exn
- (begin
- (print "Exception: " exn)
- (set! *runremote* #f))
- (if (and (not (args:get-arg "-server")) ;; no point in the server using the server using the server
- ((rpc:procedure 'serve:login host portn) *toppath*))
- (begin
- (debug:print 2 "INFO: Connected to " host ":" port)
- (set! *runremote* (vector host portn)))
- (begin
- (debug:print 2 "INFO: Failed to connect to " host ":" port)
- (set! *runremote* #f)))))
- (debug:print 2 "INFO: no server available"))))
+ (if *runremote*
+ (debug:print 0 "ERROR: Attempt to connect to server but already connected")
+ (let* ((hostinfo (db:get-var db "SERVER"))
+ (hostdat (if hostinfo (string-split hostinfo ":")))
+ (host (if hostinfo (car hostdat)))
+ (port (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) #f)))
+ (if (and port
+ (string->number port))
+ (let ((portn (string->number port)))
+ (debug:print 2 "INFO: Setting up to connect to host " host ":" port)
+ (handle-exceptions
+ exn
+ (begin
+ (print "Exception: " exn)
+ (set! *runremote* #f))
+ (if (and (not (args:get-arg "-server")) ;; no point in the server using the server using the server
+ ((rpc:procedure 'serve:login host portn) *toppath*))
+ (begin
+ (debug:print 2 "INFO: Connected to " host ":" port)
+ (set! *runremote* (vector host portn)))
+ (begin
+ (debug:print 2 "INFO: Failed to connect to " host ":" port)
+ (set! *runremote* #f)))))
+ (debug:print 2 "INFO: no server available")))))
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -1,7 +1,8 @@
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking)
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp rpc)
(import (prefix sqlite3 sqlite3:))
+(import (prefix rpc rpc:))
(declare (unit tests))
(declare (uses db))
(declare (uses common))
(declare (uses items))
@@ -11,11 +12,11 @@
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
-(define (register-test db run-id test-name item-path)
+(define (tests:register-test db run-id test-name item-path)
(let ((item-paths (if (equal? item-path "")
(list item-path)
(list item-path ""))))
(for-each
(lambda (pth)
@@ -377,5 +378,16 @@
(define (test:archive db test-id)
#f)
(define (test:archive-tests db keynames target)
#f)
+
+;;======================================================================
+;; R P C
+;;======================================================================
+
+(define (rtests:register-test db run-id test-name item-path)
+ (if *runremote*
+ (let ((host (vector-ref *runremote* 0))
+ (port (vector-ref *runremote* 1)))
+ ((rpc:procedure 'rtests:register-test host port) run-id test-name item-path))
+ (tests:register-test db run-id test-name item-path)))