Megatest

Changes On Branch v1.64-minimt
Login

Changes In Branch v1.64-minimt Excluding Merge-Ins

This is equivalent to a diff from eaf721a3d3 to d806a4bc74

2017-06-27
22:23
Switched back to doing cleaning out of old records in -cleanup-db and added cleanup of test_rundat and test_steps tables. check-in: 299fe5e984 user: matt tags: v1.64
2017-06-25
22:33
Pulled in minimt (for testing things). No need to leave it on a branch. Focus is now on v1.65 check-in: 2a906e05b0 user: matt tags: v1.65
22:03
Syncing up with v1.64 check-in: 346da738c4 user: matt tags: v1.65
21:56
minor improvements to minimt Closed-Leaf check-in: d806a4bc74 user: matt tags: v1.64-minimt
16:20
Added direct.scm for the direct to db connection test check-in: 987ac55bdd user: matt tags: v1.64-minimt
15:26
Added minimt, a minimal faux megatest to use in testing out server options, db access tricks and other ideas. check-in: 9cd3c289b8 user: matt tags: v1.64-minimt
2017-06-22
23:12
A few more missing includes check-in: eaf721a3d3 user: mrwellan tags: v1.64
22:13
Added missing include check-in: 36f2395e63 user: mrwellan tags: v1.64

Modified common.scm from [85a0309836] to [337f689b36].

829
830
831
832
833
834
835
836
837




838
839
840
841
842
843
844
829
830
831
832
833
834
835


836
837
838
839
840
841
842
843
844
845
846







-
-
+
+
+
+







      #f
      (let loop ((hed (car dirs))
		 (tal (cdr dirs)))
	(let ((res (or (and (directory? hed)
			    (file-write-access? hed)
			    hed)
		       (handle-exceptions
			exn
			#f
			   exn
			   (begin
			     (debug:print-info 0 *default-log-port* "could not create " hed ", this might cause problems down the road.")
			     #f)
			(create-directory hed #t)))))
	  (if (and (string? res)
		   (directory? res))
	      res
	      (if (null? tal)
		  #f
		  (loop (car tal)(cdr tal))))))))
1479
1480
1481
1482
1483
1484
1485
1486

1487




1488
1489
1490

1491
1492
1493
1494
1495
1496
1497
1481
1482
1483
1484
1485
1486
1487

1488
1489
1490
1491
1492
1493
1494
1495

1496
1497
1498
1499
1500
1501
1502
1503







-
+

+
+
+
+


-
+







          ((< (+ load (/ (random 250) 1000))         ;; add a random factor to keep from getting in a rut
              (+ best-load (/ (random 250) 1000))  )
           (set! best-load load)
           (set! best-host hostname)))))
     hosts)
    best-host))

(define (common:wait-for-cpuload maxload numcpus waitdelay #!key (count 1000) (msg #f)(remote-host #f))
(define (common:wait-for-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f))
  (let* ((loadavg (common:get-cpu-load remote-host))
	 (numcpus (if (< 1 numcpus-in) ;; not possible
		      (common:get-num-cpus remote-host)
		      numcpus-in))
	 (maxload (max maxload-in 0.5)) ;; so maxload must be greater than 0.5 for now BUG - FIXME?
	 (first   (car loadavg))
	 (next    (cadr loadavg))
	 (adjload (* maxload numcpus))
	 (adjload (* maxload (max 1 numcpus))) ;; possible bug where numcpus (or could be maxload) is zero, crude fallback is to at least use 1
	 (loadjmp (- first next)))
    (cond
     ((and (> first adjload)
	   (> count 0))
      (debug:print-info 0 *default-log-port* "waiting " waitdelay " seconds due to load " first " exceeding max of " adjload " " (if msg msg ""))
      (thread-sleep! waitdelay)
      (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1)))

Added minimt/Makefile version [a3a84a9e52].







1
2
3
4
5
6
+
+
+
+
+
+
minimt : minimt.scm db.scm setup.scm direct.scm
	csc minimt.scm

clean :
	rm -rf runtest/*

Added minimt/db.scm version [0203800d78].






































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
;; pretend to be a simplified Megatest

(use sql-de-lite defstruct)

;; init the db - NOTE: takes a db NOT a dbconn
;;
(define (init-db db)
  (with-transaction
   db
   (lambda ()
     (for-each
      (lambda (qrystr)
	(exec (sql db qrystr)))
      '("CREATE TABLE IF NOT EXISTS runs 
           (id        INTEGER PRIMARY KEY,
            target    TEXT NOT NULL,
            run_name  TEXT NOT NULL,
            state     TEXT NOT NULL,
            status    TEXT NOT NULL,
            CONSTRAINT runs_constraint UNIQUE (run_name));"
	"CREATE TABLE IF NOT EXISTS tests
           (id        INTEGER PRIMARY KEY,
            run_id    INTEGER NOT NULL,
            test_name TEXT NOT NULL,
            state     TEXT NOT NULL,
            status    TEXT NOT NULL,
            start_time INTEGER DEFAULT (strftime('%s','now')),
            end_time   INTEGER DEFAULT -1,
            CONSTRAINT tests_constraint UNIQUE (run_id,test_name));"
	"CREATE TABLE IF NOT EXISTS steps
           (id        INTEGER PRIMARY KEY,
            test_id   INTEGER NOT NULL,
            step_name  TEXT NOT NULL,
            state     TEXT NOT NULL,
            status    TEXT NOT NULL,
            CONSTRAINT step_constraint UNIQUE (test_id,step_name));")))))

(defstruct dbconn-dat
  dbh       ;; the database handle
  writeable ;; do we have write access?
  path      ;; where the db lives
  name      ;; name of the db
  )

;; open the database, return a dbconn struct
(define (open-create-db path fname init)
  (let* ((fullname       (conc path "/" fname))
	 (already-exists (file-exists? fullname))
	 (write-access   (and (file-write-access? path)
			      (or (not already-exists)
				  (and already-exists
				       (file-write-access? fullname)))))
	 (db             (if (or already-exists write-access)
			     (open-database fullname)
			     (begin
			       (print "FATAL: No existing db and no write access thus cannot create " fullname)  ;; no db and no write access cannot proceed.
			       (exit 1))))
	 (dbconn         (make-dbconn-dat)))
    (set-busy-handler! db (busy-timeout 30000)) ;; set a busy timeout
    (exec (sql db "PRAGMA synchronous=0;"))
    (if (and init write-access (not already-exists))
	(init db))
    (dbconn-dat-dbh-set!       dbconn db)
    (dbconn-dat-writeable-set! dbconn write-access)
    (dbconn-dat-path-set!      dbconn path)
    (dbconn-dat-name-set!      dbconn fname)
    dbconn))

(define-inline (get-db dbconn)
  (dbconn-dat-dbh dbconn))

;; RUNS

;; create a run
(define (create-run dbconn target run-name)
  (exec (sql (get-db dbconn) "INSERT INTO runs (run_name,target,state,status) VALUES (?,?,'NEW','na');")
	run-name target))

;; get a run id
(define (get-run-id dbconn target run-name)
  (first-column (query fetch (sql (get-db dbconn) "SELECT id FROM runs WHERE target=? AND run_name=?;")
		       target run-name)))

;; TESTS

(defstruct test-dat
  id
  run-id
  test-name
  state
  status)

;; create a test
(define (create-test dbconn run-id test-name)
  (exec (sql (get-db dbconn) "INSERT INTO tests (run_id,test_name,state,status) VALUES (?,?,'NOT_STARTED','na');")
	run-id test-name))

;; get a test id
(define (get-test-id dbconn run-id test-name)
  (first-column (query fetch (sql (get-db dbconn) "SELECT id FROM tests WHERE run_id=? AND test_name=?;")
		       run-id test-name)))

;; get the data for given test-id
(define (test-get-record dbconn test-id)
  (let* ((row (query fetch-row (sql (get-db dbconn) "SELECT id,run-id,test_name,state,status FROM tests WHERE test_id=?;")
		     test-id)))
    (make-test-dat
     id:        (list-ref row 0)
     run-id:    (list-ref row 1)
     test-name: (list-ref row 2)
     state:     (list-ref row 3)
     status:    (list-ref row 4))))
     
  
(define (test-set-state-status dbconn test-id new-state new-status)
  (exec (sql (get-db dbconn) "UPDATE tests SET state=?,status=?,end_time=? WHERE id=?;")
	new-state new-status (current-seconds) test-id))

;; STEPS

;; create a step
(define (create-step dbconn test-id step-name)
  (exec (sql (get-db dbconn) "INSERT INTO steps (test_id,step_name,state,status) VALUES (?,?,'NOT_STARTED','na');")
	test-id step-name))

;; get a step id
(define (get-step-id dbconn test-id step-name)
  (first-column (query fetch (sql (get-db dbconn) "SELECT id FROM steps WHERE test_id=? AND step_name=?;")
		       test-id step-name)))

(define (step-set-state-status dbconn step-id new-state new-status)
  (exec (sql (get-db dbconn) "UPDATE steps SET state=?,status=? WHERE id=?;")
	new-state new-status step-id))

Added minimt/direct.scm version [61661674b3].











1
2
3
4
5
6
7
8
9
10
+
+
+
+
+
+
+
+
+
+
;; direct API, call the db calls directly

(define rmt:create-run create-run)
(define rmt:create-step create-step)
(define rmt:create-test create-test)
(define rmt:get-test-id get-test-id)
(define rmt:get-run-id  get-run-id)
(define rmt:open-create-db open-create-db)
(define rmt:step-set-state-status step-set-state-status)
(define rmt:test-set-state-status test-set-state-status)

Added minimt/minimt.scm version [90b98f3b9a].
















































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
(use posix)

(include "db.scm")

;; define following in setup.scm
;;    *remotehost*  => host for "tests"
;;    *homehost*    => host for servers
;;    *homepath*    => directory from which to run
;;    *numtests*    => how many tests to simulate for each run
;;    *numruns*     => how many runs to simulate
;;    
(include "setup.scm")

(include "direct.scm") ;; direct db calls

;; RUN A TEST
(define (run-test dbconn run-id test-name)
  (rmt:create-test dbconn run-id test-name)
  (let ((test-id (rmt:get-test-id dbconn run-id test-name)))
    (rmt:test-set-state-status dbconn test-id "LAUNCHED" "na")
    (thread-sleep! *launchdelay*)
    (rmt:test-set-state-status dbconn test-id "RUNNING" "na")
    (let loop ((step-num 0))
      (let ((step-name (conc "step" step-num)))
       (rmt:create-step dbconn test-id step-name)
       (let ((step-id (get-step-id dbconn test-id step-name)))
	 (rmt:step-set-state-status dbconn step-id "START" -1)
	 (thread-sleep! *stepdelay*)
	 (rmt:step-set-state-status dbconn step-id "END" 0)
	 (print"   STEP: " step-name " done.")))
      (if (< step-num *numsteps*)
	  (loop (+ step-num 1))))
    (rmt:test-set-state-status dbconn test-id "COMPLETED" (if (> (random 10) 2) "PASS" "FAIL"))
    (print "TEST: " test-name " done.")
    test-id))

;; RUN A RUN
(define (run-run dbconn target run-name num-tests)
  (rmt:create-run dbconn target run-name)
  (let ((run-id (rmt:get-run-id dbconn target run-name)))
    (let loop ((test-num 0))
      (system (conc "NBFAKE_LOG=test-" test-num "-run-id-" run-id ".log NBFAKE_HOST=" *remotehost* " nbfake minimt runtest " run-id " test-" test-num))
      (if (< test-num num-tests)
	  (loop (+ test-num 1))))))

;; Do what is asked
(let ((args (cdr (argv))))
  (if (< (length args) 1)
      (print
       "Usage: minimt [options]" "
  runtest run-id testname
  runrun  target runname")
      (let ((cmd    (car args))
	    (dbconn (rmt:open-create-db *homepath* "mt.db" init-db)))
	(change-directory *homepath*)
	(case (string->symbol cmd)
	  ((runtest)
	   (let ((run-id    (string->number (cadr args)))
		 (test-name (caddr args)))
	     (print "Launching test " test-name " for run-id " run-id)
	     (run-test dbconn run-id test-name)))
	  ((runrun)
	   (let ((target   (cadr args))
		 (run-name (caddr args)))
	     (run-run dbconn target run-name *numtests*)
	     (print "Use: sqlite3 runtest/mt.db 'select max(end_time)-min(start_time) from tests;' to see the total run time")
	     ))
	  ((runall)
	   (for-each
	    (lambda (target)
	      (let loop ((run-num 0))
		(thread-sleep! *rundelay*)
		(system (conc "NBFAKE_LOG=run-" target "-" run-num ".log nbfake minimt runrun " target " run-" run-num))
		(if (< run-num *numruns*)
		    (loop (+ run-num 1)))))
	    *targets*))
	  (else
	   (print "Command: " cmd " not recognised. Run without params to see help.")))
	(close-database (dbconn-dat-dbh dbconn)))))

Added minimt/setup.scm version [f4cfd22ef8].


















1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
(define *remotehost* "orion")
(define *homehost*   "zeus")
(define *homepath*   "/nfs/phoebe/disk1/home/mfs_matt/data/megatest/minimt/runtest")
(define *numsteps*   100)
(define *numtests*   50)
(define *numruns*    5)
(define *targets*    '("targ1"))
(define *testdelay*  0)
(define *rundelay*   0)
(define *launchdelay* 0)
(define *stepdelay*   0)

(use trace)
(trace-call-sites #t)
(trace
;;  open-create-db
 )

Modified rpctest/rpctest-continuous-client.scm from [ea7c1d49cf] to [bb9e39b0dd].

15
16
17
18
19
20
21
22

23
24
25
26
27
28
29
15
16
17
18
19
20
21

22
23
24
25
26
27
28
29







-
+







(define operation (string->symbol (car (command-line-arguments))))
(define param (cadr (command-line-arguments)))
(print "Operation: " operation ", param: " param)

;; have a pool of db's to pick from
(define *dbpool* '())
(define *pool-mutex* (make-mutex))
1

(define (get-db)
  (mutex-lock! *pool-mutex*)
  (if (null? *dbpool*)
      (begin
	(mutex-unlock! *pool-mutex*)
	(let ((db (open-database param)))
	  (set-busy-handler! db (busy-timeout 10000))