| ︙ | | | ︙ | |
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
|
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;;======================================================================
;;======================================================================
;; Database access
;;======================================================================
(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml)
(import (prefix sqlite3 sqlite3:))
(declare (unit db))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(define (open-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
(let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname)
(configdat (car *configinfo*))
(dbexists (file-exists? dbpath))
(db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath))
(handler (make-busy-timeout 36000)))
|
>
>
>
>
|
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
|
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;;======================================================================
;;======================================================================
;; Database access
;;======================================================================
(require-extension (srfi 18) extras tcp rpc)
(import (prefix rpc rpc:))
(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml)
(import (prefix sqlite3 sqlite3:))
(declare (unit db))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")
(define (open-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
(let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname)
(configdat (car *configinfo*))
(dbexists (file-exists? dbpath))
(db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath))
(handler (make-busy-timeout 36000)))
|
| ︙ | | | ︙ | |
83
84
85
86
87
88
89
90
91
92
93
94
95
96
|
final_logf TEXT DEFAULT 'logs/final.log',
logdat BLOB,
run_duration INTEGER DEFAULT 0,
comment TEXT DEFAULT '',
event_time TIMESTAMP,
fail_count INTEGER DEFAULT 0,
pass_count INTEGER DEFAULT 0,
CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path)
);")
(sqlite3:execute db "CREATE INDEX tests_index ON tests (run_id, testname);")
(sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps
(id INTEGER PRIMARY KEY,
test_id INTEGER,
|
>
|
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
|
final_logf TEXT DEFAULT 'logs/final.log',
logdat BLOB,
run_duration INTEGER DEFAULT 0,
comment TEXT DEFAULT '',
event_time TIMESTAMP,
fail_count INTEGER DEFAULT 0,
pass_count INTEGER DEFAULT 0,
archived INTEGER DEFAULT 0, -- 0=no, 1=in progress, 2=yes
CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path)
);")
(sqlite3:execute db "CREATE INDEX tests_index ON tests (run_id, testname);")
(sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps
(id INTEGER PRIMARY KEY,
test_id INTEGER,
|
| ︙ | | | ︙ | |
128
129
130
131
132
133
134
135
136
137
138
139
140
141
|
comment TEXT DEFAULT '',
status TEXT DEFAULT 'n/a',
type TEXT DEFAULT '',
CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));")
;; Must do this *after* running patch db !! No more.
(db:set-var db "MEGATEST_VERSION" megatest-version)
))
db))
;;======================================================================
;; TODO:
;; put deltas into an assoc list with version numbers
;; apply all from last to current
;;======================================================================
|
>
|
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
|
comment TEXT DEFAULT '',
status TEXT DEFAULT 'n/a',
type TEXT DEFAULT '',
CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));")
;; Must do this *after* running patch db !! No more.
(db:set-var db "MEGATEST_VERSION" megatest-version)
))
(server:client-setup db)
db))
;;======================================================================
;; TODO:
;; put deltas into an assoc list with version numbers
;; apply all from last to current
;;======================================================================
|
| ︙ | | | ︙ | |
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
|
(patch-db))
((< mver 1.29)
(db:set-var db "MEGATEST_VERSION" 1.29)
(sqlite3:execute db "ALTER TABLE test_steps ADD COLUMN logfile TEXT DEFAULT '';")
(sqlite3:execute db "ALTER TABLE tests ADD COLUMN shortdir TEXT DEFAULT '';"))
((< mver 1.36)
(db:set-var db "MEGATEST_VERSION" 1.36)
(sqlite3:execute db "ALTER TABLER test_meta ADD COLUMN jobgroup TEXT DEFAULT 'default';"))
((< mver megatest-version)
(db:set-var db "MEGATEST_VERSION" megatest-version))))))
;;======================================================================
;; meta get and set vars
;;======================================================================
|
|
>
>
>
|
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
|
(patch-db))
((< mver 1.29)
(db:set-var db "MEGATEST_VERSION" 1.29)
(sqlite3:execute db "ALTER TABLE test_steps ADD COLUMN logfile TEXT DEFAULT '';")
(sqlite3:execute db "ALTER TABLE tests ADD COLUMN shortdir TEXT DEFAULT '';"))
((< mver 1.36)
(db:set-var db "MEGATEST_VERSION" 1.36)
(sqlite3:execute db "ALTER TABLE test_meta ADD COLUMN jobgroup TEXT DEFAULT 'default';"))
((< mver 1.37)
(db:set-var db "MEGATEST_VERSION" 1.37)
(sqlite3:execute db "ALTER TABLE tests ADD COLUMN archived INTEGER DEFAULT 0;"))
((< mver megatest-version)
(db:set-var db "MEGATEST_VERSION" megatest-version))))))
;;======================================================================
;; meta get and set vars
;;======================================================================
|
| ︙ | | | ︙ | |
410
411
412
413
414
415
416
417
418
419
420
421
422
423
|
(sqlite3:execute db "DELETE FROM tests WHERE state=? AND run_id=?;" state run-id))
(define (db:test-set-state-status-by-id db test-id newstate newstatus newcomment)
(if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id))
(if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id))
(if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment test-id)))
(define (db:get-count-tests-running db)
(let ((res 0))
(sqlite3:for-each-row
(lambda (count)
(set! res count))
db
"SELECT count(id) FROM tests WHERE state = 'RUNNING' OR state = 'LAUNCHED' OR state = 'REMOTEHOSTSTART';")
|
>
>
>
>
|
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
|
(sqlite3:execute db "DELETE FROM tests WHERE state=? AND run_id=?;" state run-id))
(define (db:test-set-state-status-by-id db test-id newstate newstatus newcomment)
(if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id))
(if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id))
(if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment test-id)))
(define (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state)
(sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;"
state status run-id test-name item-path))
(define (db:get-count-tests-running db)
(let ((res 0))
(sqlite3:for-each-row
(lambda (count)
(set! res count))
db
"SELECT count(id) FROM tests WHERE state = 'RUNNING' OR state = 'LAUNCHED' OR state = 'REMOTEHOSTSTART';")
|
| ︙ | | | ︙ | |
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
|
;;
(define (db:test-set-rundir! db run-id testname item-path rundir)
(sqlite3:execute
db
"UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;"
rundir run-id testname item-path))
;; Misc. test related queries
(define (db:test-get-paths-matching db keynames target)
(let* ((res '())
(itempatt (if (args:get-arg "-itempatt")(args:get-arg "-itempatt") "%"))
(testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%"))
(statepatt (if (args:get-arg ":state") (args:get-arg ":state") "%"))
(statuspatt (if (args:get-arg ":status") (args:get-arg ":status") "%"))
(runname (if (args:get-arg ":runname") (args:get-arg ":runname") "%"))
|
>
>
>
|
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
|
;;
(define (db:test-set-rundir! db run-id testname item-path rundir)
(sqlite3:execute
db
"UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;"
rundir run-id testname item-path))
;;======================================================================
;; Misc. test related queries
;;======================================================================
(define (db:test-get-paths-matching db keynames target)
(let* ((res '())
(itempatt (if (args:get-arg "-itempatt")(args:get-arg "-itempatt") "%"))
(testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%"))
(statepatt (if (args:get-arg ":state") (args:get-arg ":state") "%"))
(statuspatt (if (args:get-arg ":status") (args:get-arg ":status") "%"))
(runname (if (args:get-arg ":runname") (args:get-arg ":runname") "%"))
|
| ︙ | | | ︙ | |
504
505
506
507
508
509
510
511
512
513
514
515
516
517
|
(debug:print 3 "qrystr: " qrystr)
(sqlite3:for-each-row
(lambda (p)
(set! res (cons p res)))
db
qrystr)
res))
;;======================================================================
;; Tests meta data
;;======================================================================
;; read the record given a testname
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
|
(debug:print 3 "qrystr: " qrystr)
(sqlite3:for-each-row
(lambda (p)
(set! res (cons p res)))
db
qrystr)
res))
(define (db:test-get-test-records-matching db keynames target)
(let* ((res '())
(itempatt (if (args:get-arg "-itempatt")(args:get-arg "-itempatt") "%"))
(testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%"))
(statepatt (if (args:get-arg ":state") (args:get-arg ":state") "%"))
(statuspatt (if (args:get-arg ":status") (args:get-arg ":status") "%"))
(runname (if (args:get-arg ":runname") (args:get-arg ":runname") "%"))
(keystr (string-intersperse
(map (lambda (key val)
(conc "r." key " like '" val "'"))
keynames
(string-split target "/"))
" AND "))
(qrystr (conc "SELECT
t.id
t.run_id
t.testname
t.host
t.cpuload
t.diskfree
t.uname
t.rundir
t.shortdir
t.item_path
t.state
t.status
t.attemptnum
t.final_logf
t.logdat
t.run_duratio
t.comment
t.event_time
t.fail_count
t.pass_count
t.archived
FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE "
keystr " AND r.runname LIKE '" runname "' AND item_path LIKE '" itempatt "' AND testname LIKE '"
testpatt "' AND t.state LIKE '" statepatt "' AND t.status LIKE '" statuspatt
"'ORDER BY t.event_time ASC;")))
(debug:print 3 "qrystr: " qrystr)
(sqlite3:for-each-row
(lambda (p)
(set! res (cons p res)))
db
qrystr)
res))
(define (db:test-update-meta-info db run-id testname item-path minutes cpuload diskfree tmpfree)
(if (not item-path)(begin (debug:print 0 "WARNING: ITEMPATH not set.") (set! item-path "")))
;; (let ((testinfo (db:get-test-info db run-id testname item-path)))
;; (if (and (not (equal? (db:test-get-status testinfo) "COMPLETED"))
;; (not (equal? (db:test-get-status testinfo) "KILLREQ"))
(sqlite3:execute
db
"UPDATE tests SET cpuload=?,diskfree=?,run_duration=?,state='RUNNING' WHERE run_id=? AND testname=? AND item_path=? AND state NOT IN ('COMPLETED','KILLREQ','KILLED');"
cpuload
diskfree
minutes
run-id
testname
item-path))
;;======================================================================
;; Tests meta data
;;======================================================================
;; read the record given a testname
|
| ︙ | | | ︙ | |
790
791
792
793
794
795
796
797
798
799
800
801
802
803
|
(if (not (or parent-waiton-met item-waiton-met))
(set! result (cons waitontest-name result)))
;; if the test is not found then clearly the waiton is not met...
(if (not ever-seen)(set! result (cons waitontest-name result)))))
waitons)
(delete-duplicates result))))
;;======================================================================
;; Extract ods file from the db
;;======================================================================
;; runspatt is a comma delimited list of run patterns
;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. )
(define (db:extract-ods-file db outputfile keypatt-alist runspatt pathmod)
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
|
(if (not (or parent-waiton-met item-waiton-met))
(set! result (cons waitontest-name result)))
;; if the test is not found then clearly the waiton is not met...
(if (not ever-seen)(set! result (cons waitontest-name result)))))
waitons)
(delete-duplicates result))))
(define (db:teststep-set-status! db run-id test-name teststep-name state-in status-in item-path comment logfile)
(debug:print 4 "run-id: " run-id " test-name: " test-name)
(let* ((state (check-valid-items "state" state-in))
(status (check-valid-items "status" status-in))
(testdat (db:get-test-info db run-id test-name item-path)))
(debug:print 5 "testdat: " testdat)
(if (and testdat ;; if the section exists then force specification BUG, I don't like how this works.
(or (not state)(not status)))
(debug:print 0 "WARNING: Invalid " (if status "status" "state")
" value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config"))
(if testdat
(let ((test-id (test:get-id testdat)))
;; FIXME - this should not update the logfile unless it is specified.
(sqlite3:execute db
"INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,strftime('%s','now'),?,?);"
test-id teststep-name state-in status-in (if comment comment "") (if logfile logfile ""))
#t) ;; fake out a #t - could be execute is returning something complicated
(debug:print 0 "ERROR: Can't update " test-name " for run " run-id " -> no such test in db"))))
;;======================================================================
;; Extract ods file from the db
;;======================================================================
;; runspatt is a comma delimited list of run patterns
;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. )
(define (db:extract-ods-file db outputfile keypatt-alist runspatt pathmod)
|
| ︙ | | | ︙ | |
914
915
916
917
918
919
920
|
(debug:print 0 "WARNING: path given, " outputfile " is relative, prefixing with current directory")
(conc (current-directory) "/" outputfile)))
results)
;; brutal clean up
(system "rm -rf tempdir")))
;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%")
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
|
(debug:print 0 "WARNING: path given, " outputfile " is relative, prefixing with current directory")
(conc (current-directory) "/" outputfile)))
results)
;; brutal clean up
(system "rm -rf tempdir")))
;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%")
;;======================================================================
;; REMOTE DB ACCESS VIA RPC
;;======================================================================
(define (rdb:set-tests-state-status db run-id testnames currstate currstatus newstate newstatus)
(if *runremote*
(let ((host (vector-ref *runremote* 0))
(port (vector-ref *runremote* 1)))
((rpc:procedure 'rdb:set-tests-state-status host port)
run-id testnames currstate currstatus newstate newstatus))
(db:set-tests-state-status db run-id testnames currstate currstatus newstate newstatus)))
(define (rdb:teststep-set-status! db run-id test-name teststep-name state-in status-in itemdat comment logfile)
(let ((item-path (item-list->path itemdat)))
(if *runremote*
(let ((host (vector-ref *runremote* 0))
(port (vector-ref *runremote* 1)))
((rpc:procedure 'rdb:teststep-set-status! host port)
run-id test-name teststep-name state-in status-in item-path comment logfile))
(db:teststep-set-status! db run-id test-name teststep-name state-in status-in item-path comment logfile))))
(define (rdb:test-update-meta-info db run-id testname itemdat minutes cpuload diskfree tmpfree)
(let ((item-path (item-list->path itemdat)))
(if *runremote*
(let ((host (vector-ref *runremote* 0))
(port (vector-ref *runremote* 1)))
((rpc:procedure 'rdb:test-update-meta-info host port)
run-id testname itemdat minutes cpuload diskfree tmpfree))
(db:test-update-meta-info db run-id testname item-path minutes cpuload diskfree tmpfree))))
(define (rdb:test-set-state-status-by-run-id-testname db run-id test-name item-path status state)
(if *runremote*
(let ((host (vector-ref *runremote* 0))
(port (vector-ref *runremote* 1)))
((rpc:procedure 'rdb:test-set-state-status-by-run-id-testname host port)
run-id test-name item-path status state))
(db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state)))
|