Megatest

Check-in [37693582eb]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Switched paths to filedb
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | normalize-db
Files: files | file ages | folders
SHA1: 37693582eb5dbe4605e36d0dc33b0457a974da87
User & Date: matt on 2013-10-30 00:03:12
Other Links: branch diff | manifest | tags
Context
2013-10-31
02:06
yada Closed-Leaf check-in: e1254f35a8 user: matt tags: normalize-db
2013-10-30
00:03
Switched paths to filedb check-in: 37693582eb user: matt tags: normalize-db
2013-10-29
15:53
Added migration to new format but -test-path not ported check-in: 541aae0765 user: mrwellan tags: normalize-db
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified Makefile from [d1830ccc25] to [78fbba5d85]. 

1
2
3
4
5
6
7
8
9

10
11
12
13
14
15
16

1
2
3
4
5
6
7
8

9
10
11
12
13
14
15
16









-
+








# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)'
PREFIX=$(PWD)
CSCOPTS= 
INSTALL=install
SRCFILES = common.scm items.scm launch.scm \
           ods.scm runconfig.scm server.scm configf.scm \
           db.scm keys.scm margs.scm megatest-version.scm \
           process.scm runs.scm tasks.scm tests.scm genexample.scm \
	   fs-transport.scm http-transport.scm \
	   fs-transport.scm http-transport.scm filedb.scm \
           client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \
	   tree.scm ezsteps.scm lock-queue.scm sdb.scm

GUISRCF  = dashboard-tests.scm dashboard-guimonitor.scm 

OFILES   = $(SRCFILES:%.scm=%.o)
GOFILES  = $(GUISRCF:%.scm=%.o)
︙

Modified common.scm from [94de7ea81e] to [3b6880fd72].

︙
87
88
89
90
91
92
93


94
95
96
97
98
99
100

87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102








+
+








  (set! *test-info*          (make-hash-table))
  (set! *run-info-cache*     (make-hash-table))
  (set! *env-vars-by-run-id* (make-hash-table))
  (set! *test-id-cache*      (make-hash-table)))

;; Generic string database (normalization of sorts)
(define sdb:qry #f) ;; (make-sdb:qry)) ;;  'init #f)
;; Generic path database (normalization of sorts)
(define *fdb* #f)

;;======================================================================
;; S T A T E S   A N D   S T A T U S E S
;;======================================================================

(define *common:std-states*   
  (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ" "STUCK"))
︙

Modified dashboard-tests.scm from [6bf2b48df2] to [f5f060e123].

︙
24
25
26
27
28
29
30

31
32
33
34
35
36
37

24
25
26
27
28
29
30
31
32
33
34
35
36
37
38








+









(declare (unit dashboard-tests))
(declare (uses common))
(declare (uses db))
(declare (uses gutils))
(declare (uses ezsteps))
(declare (uses sdb))
(declare (uses filedb))

(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")

(define (test-info-panel testdat store-label widgets)
  (iup:frame
︙
382
383
384
385
386
387
388
389

390
391
392
393
394
395
396

383
384
385
386
387
388
389

390
391
392
393
394
395
396
397








-
+








						     (debug:print-info 2 "test db access issue: " ((condition-property-accessor 'exn 'message) exn))
						     (open-run-close db:get-test-info-by-id db test-id )))))
			       (cond
				((and need-update newtestdat)
				 (set! testdat newtestdat)
				 (set! teststeps    (db:get-compressed-steps test-id work-area: rundir))
				 (set! logfile      (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat)))
				 (set! rundir       (sdb:qry 'getstr (db:test-get-rundir testdat)))
				 (set! rundir       (filedb:get-path *fdb* (db:test-get-rundir testdat)))
				 (set! testfullname (db:test-get-fullname testdat))
				 ;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n    "))
				 (if (eq? curr-mod-time db-mod-time) ;; do only once if same
				     (set! db-mod-time (+ curr-mod-time 1))
				     (set! db-mod-time curr-mod-time))
				 (set! last-update (current-milliseconds))
				 (set! request-update #f) ;; met the need ...
︙

Modified db.scm from [6dd09b2808] to [ab44399a76].

︙
27
28
29
30
31
32
33

34
35
36
37
38
39
40

27
28
29
30
31
32
33
34
35
36
37
38
39
40
41








+








(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses fs-transport))
(declare (uses client))
(declare (uses mt))
(declare (uses sdb))
(declare (uses filedb))

(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")

;; timestamp type (val1 val2 ...)
︙
83
84
85
86
87
88
89

90
91
92
93
94
95
96

84
85
86
87
88
89
90
91
92
93
94
95
96
97
98








+








	(set! *db-write-access* write-access)) ;; only unset so other db's also can use this control
    (debug:print-info 11 "open-db, dbpath=" dbpath " argv=" (argv))
    (sqlite3:set-busy-handler! db handler)
    (if (not dbexists)
	(db:initialize db))
    (db:set-sync db)
    (set! sdb:qry (make-sdb:qry)) ;; we open the normalization helpers here
    (set! *fdb*   (filedb:open-db (conc *toppath* "/db/paths.db")))
    db))

;; keeping it around for debugging purposes only
(define (open-run-close-no-exception-handling  proc idb . params)
  (debug:print-info 11 "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
  (let* ((db   (if idb 
		   (if (procedure? idb)
︙
291
292
293
294
295
296
297
298

299
300
301
302
303
304
305

293
294
295
296
297
298
299

300
301
302
303
304
305
306
307








-
+








	(debug:print-info 11 "open-test-db END (unsucessful)" work-area)
	#f)))

;; find and open the testdat.db file for an existing test
(define (db:open-test-db-by-test-id db test-id #!key (work-area #f))
  (let* ((test-path (if work-area
			work-area
			(sdb:qry 'getstr (cdb:remote-run db:test-get-rundir-from-test-id db test-id)))))
			(filedb:get-path *fdb* (cdb:remote-run db:test-get-rundir-from-test-id db test-id)))))
    (debug:print 3 "TEST PATH: " test-path)
    (open-test-db test-path)))

(define (db:testdb-initialize db)
  (debug:print 11 "db:testdb-initialize START")
  (for-each
   (lambda (sqlcmd)
︙

Modified ezsteps.scm from [7af8bc1e54] to [254409a174].

︙
15
16
17
18
19
20
21

22
23
24
25
26
27
28
29

30
31
32
33
34
35
36

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

30
31
32
33
34
35
36
37








+







-
+









(declare (unit ezsteps))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses sdb))
(declare (uses filedb))

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")

(define (ezsteps:run-from testdat start-step-name run-one)
  (let* ((test-run-dir  (db:test-get-rundir testdat))
  (let* ((test-run-dir  (filedb:get-path *fdb* (db:test-get-rundir testdat)))
	 (testconfig    (read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars"))
	 (ezstepslst    (hash-table-ref/default testconfig "ezsteps" '()))
	 (run-mutex     (make-mutex))
	 (rollup-status 0)
	 (exit-info     (vector #t #t #t))
	 (test-id       (db:test-get-id testdat))
	 (test-name     (db:test-get-testname testdat))
︙

Modified filedb.scm from [d77bc6ba17] to [a67747bbf8].

︙
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

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








-
+


















+
+
+
+
+








	 (dbexists (file-exists? dbpath))
	 (db (sqlite3:open-database dbpath)))
    (filedb:fdb-set-db!        fdb db)
    (filedb:fdb-set-dbpath!    fdb dbpath)
    (filedb:fdb-set-pathcache! fdb (make-hash-table))
    (filedb:fdb-set-idcache!   fdb (make-hash-table))
    (filedb:fdb-set-partcache! fdb (make-hash-table))
    ;(sqlite3:set-busy-timeout! db 1000000)
    (sqlite3:set-busy-handler!  db (make-busy-timeout 136000))
    (if (not dbexists)
	(begin
	  (sqlite3:execute db "PRAGMA synchronous = OFF;")
	  (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id
	  (sqlite3:execute db "CREATE INDEX name_index ON names (name);")
	  ;; NB// We store a useful subset of file attributes but do not attempt to store all
	  (sqlite3:execute db "CREATE TABLE paths (id        INTEGER PRIMARY KEY,
                                                   path      TEXT,
                                                   parent_id INTEGER,
                                                   mode      INTEGER DEFAULT -1,
                                                   uid       INTEGER DEFAULT -1,
                                                   gid       INTEGER DEFAULT -1,
                                                   size      INTEGER DEFAULT -1,
                                                   mtime     INTEGER DEFAULT -1);")
	  (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);")
	  (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT,                  updated TIMESTAMP);")))
    fdb))

(define (filedb:reopen-db fdb)
  (let ((db (sqlite3:open-database (filedb:fdb-get-dbpath fdb))))
    (filedb:fdb-set-db! fdb db)
    (sqlite3:set-busy-handler!  db (make-busy-timeout 136000))))
  
(define (filedb:finalize-db! fdb)
  (sqlite3:finalize! (filedb:fdb-get-db fdb)))

(define (filedb:get-current-time-string)
  (string-chomp (time->string (seconds->local-time (current-seconds)))))

(define (filedb:get-base-id db path)
︙

Modified launch.scm from [c19f7fffaa] to [7b57bac590].

︙
18
19
20
21
22
23
24

25
26
27
28
29
30
31

18
19
20
21
22
23
24
25
26
27
28
29
30
31
32








+








(import (prefix sqlite3 sqlite3:))

(declare (unit launch))
(declare (uses common))
(declare (uses configf))
(declare (uses db))
(declare (uses sdb))
(declare (uses filedb))

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")

;;======================================================================
;; ezsteps
︙
493
494
495
496
497
498
499
500

501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521

522
523
524

525
526
527
528
529
530
531

494
495
496
497
498
499
500

501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521

522
523
524

525
526
527
528
529
530
531
532








-
+




















-
+


-
+








		      (if rd rd (conc *toppath* "/runs"))))

	 (lnkbase  (conc linktree "/" target "/" runname))
	 (lnkpath  (conc lnkbase "/" testname))
	 (lnkpathf (conc lnkpath (if not-iterated "" "/") item-path)))

    ;; Update the rundir path in the test record for all
    (cdb:test-set-rundir-by-test-id *runremote* test-id (sdb:qry 'getid lnkpathf))
    (cdb:test-set-rundir-by-test-id *runremote* test-id (filedb:register-path *fdb* lnkpathf))

    (debug:print 2 "INFO:\n       lnkbase=" lnkbase "\n       lnkpath=" lnkpath "\n  toptest-path=" toptest-path "\n     test-path=" test-path)
    (if (not (file-exists? linktree))
	(begin
	  (debug:print 0 "WARNING: linktree did not exist! Creating it now at " linktree)
	  (create-directory linktree #t))) ;; (system (conc "mkdir -p " linktree))))
    ;; create the directory for the tests dir links, this is needed no matter what...
    (if (and (not (directory-exists? lnkbase))
	     (not (file-exists? lnkbase)))
	(create-directory lnkbase #t))
    
    ;; update the toptest record with its location rundir, cache the path
    ;; This wass highly inefficient, one db write for every subtest, potentially
    ;; thousands of unnecessary updates, cache the fact it was set and don't set it 
    ;; again. 

    ;; NB - This is not working right - some top tests are not getting the path set!!!

    (if (not (hash-table-ref/default *toptest-paths* testname #f))
	(let* ((testinfo       (cdb:get-test-info-by-id *runremote* test-id)) ;;  run-id testname item-path))
	       (curr-test-path (if testinfo (sdb:qry 'getstr (db:test-get-rundir testinfo)) #f)))
	       (curr-test-path (if testinfo (filedb:get-path *fdb* (db:test-get-rundir testinfo)) #f)))
	  (hash-table-set! *toptest-paths* testname curr-test-path)
	  ;; NB// Was this for the test or for the parent in an iterated test?
	  (cdb:test-set-rundir! *runremote* run-id testname "" (sdb:qry 'getid lnkpath)) ;; toptest-path)
	  (cdb:test-set-rundir! *runremote* run-id testname "" (filedb:register-path *fdb* lnkpath)) ;; toptest-path)
	  (if (or (not curr-test-path)
		  (not (directory-exists? toptest-path)))
	      (begin
		(debug:print-info 2 "Creating " toptest-path " and link " lnkpath)
		(create-directory toptest-path #t)
		(hash-table-set! *toptest-paths* testname toptest-path)))))
︙

Modified megatest.scm from [d9a37585c9] to [cda234f61c].

︙
24
25
26
27
28
29
30

31
32
33
34
35
36
37

24
25
26
27
28
29
30
31
32
33
34
35
36
37
38








+








(declare (uses server))
(declare (uses client))
(declare (uses tests))
(declare (uses genexample))
(declare (uses daemon))
(declare (uses db))
(declare (uses sdb))
(declare (uses filedb))

(define *db* #f) ;; this is only for the repl, do not use in general!!!!

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
︙
625
626
627
628
629
630
631
632

633
634
635
636
637
638
639

626
627
628
629
630
631
632

633
634
635
636
637
638
639
640








-
+








			(if (not (or (equal? (db:test-get-status test) "PASS")
				     (equal? (db:test-get-status test) "WARN")
				     (equal? (db:test-get-state test)  "NOT_STARTED")))
			    (begin
			      (print "         cpuload:  " (db:test-get-cpuload test)
				     "\n         diskfree: " (db:test-get-diskfree test)
				     "\n         uname:    " (sdb:qry 'getstr (db:test-get-uname test))
				     "\n         rundir:   " (sdb:qry 'getstr (db:test-get-rundir test))
				     "\n         rundir:   " (filedb:get-path *fdb* (db:test-get-rundir test))
				     )
			      ;; Each test
			      ;; DO NOT remote run
			      (let ((steps (db:get-steps-for-test #f (db:test-get-id test))))
				(for-each 
				 (lambda (step)
				   (format #t
︙
1192
1193
1194
1195
1196
1197
1198
1199


1200
1201
1202
1203
1204
1205
1206

1193
1194
1195
1196
1197
1198
1199

1200
1201
1202
1203
1204
1205
1206
1207
1208








-
+
+








(if *runremote* (close-all-connections!))

;; this is the socket if we are a client
;; (if (and *runremote*
;; 	 (socket? *runremote*))
;;     (close-socket *runremote*))

(sdb:qry 'finalize! #f)
(if sdb:qry (sdb:qry 'finalize #f))
(if *fdb*   (filedb:finalize-db! *fdb*))

(if (not *didsomething*)
    (debug:print 0 help))

;; (if *runremote* (rpc:close-all-connections!))
    
(if (not (eq? *globalexitstatus* 0))
︙

Modified mt.scm from [f901ea9aed] to [3fbd491135].

︙
15
16
17
18
19
20
21

22
23
24
25
26
27
28

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








+








(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses server))
(declare (uses runs))
(declare (uses filedb))

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
︙
110
111
112
113
114
115
116
117

118
119
120
121
122
123
124

111
112
113
114
115
116
117

118
119
120
121
122
123
124
125








-
+









;;======================================================================
;;  T R I G G E R S
;;======================================================================

(define (mt:process-triggers test-id newstate newstatus)
  (let* ((test-dat      (mt:lazy-get-test-info-by-id test-id))
	 (test-rundir   (sdb:qry 'getstr (db:test-get-rundir test-dat)))
	 (test-rundir   (filedb:get-path *fdb* (db:test-get-rundir test-dat)))
	 (test-name     (db:test-get-testname test-dat))
	 (tconfig       #f)
	 (state         (if newstate  newstate  (db:test-get-state  test-dat)))
	 (status        (if newstatus newstatus (db:test-get-status test-dat))))
    (if (and (file-exists? test-rundir)
	     (directory? test-rundir))
	(begin
︙

Modified runs.scm from [00b9e6b739] to [80c3356787].

︙
17
18
19
20
21
22
23

24
25
26
27
28
29
30

17
18
19
20
21
22
23
24
25
26
27
28
29
30
31








+








(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses server))
(declare (uses mt))
(declare (uses filedb))

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
︙
1209
1210
1211
1212
1213
1214
1215
1216
1217


1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234

1235
1236
1237
1238
1239
1240
1241

1210
1211
1212
1213
1214
1215
1216


1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234

1235
1236
1237
1238
1239
1240
1241
1242








-
-
+
+
















-
+








		   ((print-run)
		    (debug:print 1 "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header)
		    action)
		   ((run-wait)
		    (debug:print 1 "Waiting for run " runkey ", run=" runnamepatt " to complete"))
		   (else
		    (debug:print-info 0 "action not recognised " action)))
		 (let ((sorted-tests     (sort tests (lambda (a b)(let ((dira (sdb:qry 'getstr (db:test-get-rundir a)))
									(dirb (sdb:qry 'getstr (db:test-get-rundir b))))
		 (let ((sorted-tests     (sort tests (lambda (a b)(let ((dira (filedb:get-path *fdb* (db:test-get-rundir a)))
									(dirb (filedb:get-path *fdb* (db:test-get-rundir b))))
								    (if (and (string? dira)(string? dirb))
									(> (string-length dira)(string-length dirb))
									#f)))))
		       (test-retry-time  (make-hash-table))
		       (allow-run-time   10)) ;; seconds to allow for killing tests before just brutally killing 'em
		   (let loop ((test (car sorted-tests))
			      (tal  (cdr sorted-tests)))
		     (let* ((test-id       (db:test-get-id test))
			    (new-test-dat  (cdb:get-test-info-by-id *runremote* test-id)))
		       (if (not new-test-dat)
			   (begin
			     (debug:print 0 "ERROR: We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!")
			     (if (not (null? tal))
				 (loop (car tal)(cdr tal))))
			   (let* ((item-path     (db:test-get-item-path new-test-dat))
				  (test-name     (db:test-get-testname new-test-dat))
				  (run-dir       (sdb:qry 'getstr (db:test-get-rundir new-test-dat)))    ;; run dir is from the link tree
				  (run-dir       (filedb:get-path *fdb* (db:test-get-rundir new-test-dat)))    ;; run dir is from the link tree
				  (real-dir      (if (file-exists? run-dir)
						     (resolve-pathname run-dir)
						     #f))
				  (test-state    (db:test-get-state new-test-dat))
				  (test-fulln    (db:test-get-fullname new-test-dat)))
			     (case action
			       ((remove-runs)
︙

Modified sdb.scm from [f2aeba1a5c] to [5d37256fc5].

︙
32
33
34
35
36
37
38
39

40
41
42
43
44
45
46
47
48

32
33
34
35
36
37
38

39


40
41
42
43
44
45
46








-
+
-
-








	 (dbexists  (let ((fe (file-exists? dbpath)))
		      (if fe 
			  fe
			  (begin
			    (create-directory (conc *toppath* "/db") #t)
			    #f))))
	 (sdb        (sqlite3:open-database dbpath))
	 (handler   (make-busy-timeout (if (args:get-arg "-override-timeout")
	 (handler   (make-busy-timeout 136000)))
					   (string->number (args:get-arg "-override-timeout"))
					   136000))))
    (sqlite3:set-busy-handler! sdb handler)
    (if (not dbexists)
	(sdb:initialize sdb))
    (sqlite3:execute sdb "PRAGMA synchronous = 1;")
    sdb))

(define (sdb:initialize sdb)
︙
78
79
80
81
82
83
84
85

86
87
88
89

90
91
92




93
94
95
96
97
98
99

76
77
78
79
80
81
82

83
84
85
86

87
88


89
90
91
92
93
94
95
96
97
98
99








-
+



-
+

-
-
+
+
+
+








	 sdb
	 "SELECT str FROM strs WHERE id=?;" id))
    str))

;; Numbers get passed though in both directions
;;
(define (make-sdb:qry #!key (fname #f))
  (let ((sdb    (sdb:open fname: fname))
  (let ((sdb    #f) ;; (sdb:open fname: fname))
	(scache (make-hash-table))
	(icache (make-hash-table)))
    (lambda (cmd var)
      ;; (if (not sdb)(set! sdb (sdb:open)))
      (if (not sdb)(set! sdb (sdb:open fname: fname)))
      (case cmd
	;; ((init)      (if (not sdb)(set! sdb (sdb:open))))
	((finalize!) (if sdb (sqlite3:finalize! sdb)))
	((finalize) (if sdb
			(begin
			  (sqlite3:finalize! sdb)
			  (set! sdb #f))))
	((getid)     (let ((id (if (or (number? var)
				       (string->number var))
				   var
				   (sdb:string->id sdb scache var))))
		       (if id
			   id
			   (begin
︙

Modified zmq-transport.scm from [397cba74a4] to [1f9025d277]. 

1

2
3
4
5
6
7
8
9

10
11
12
13
14
15
16


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17

-
+








+









;;======================================================================
;; 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 zmq)
︙

This page was generated in about 0.131s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00