Overview
Comment: | tweaks |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | trunk |
Files: | files | file ages | folders |
SHA1: |
38b08475b3d0fd57e144d330100664a8 |
User & Date: | matt on 2013-11-11 23:54:52 |
Other Links: | manifest | tags |
Context
2013-11-12
| ||
01:50 | tweaks 'n problems check-in: e90eacf59a user: matt tags: trunk | |
2013-11-11
| ||
23:54 | tweaks check-in: 38b08475b3 user: matt tags: trunk | |
23:29 | First milestone. list-runs fully functional check-in: 0d1bbbe707 user: matt tags: trunk | |
Changes
Modified api.scm from [8e03229966] to [3d6462efb6].
︙ | ︙ | |||
42 43 44 45 46 47 48 | ((get-prereqs-not-met) (apply db:get-prereqs-not-met params)) ;; RUNS ((get-run-info) (let ((res (apply db:get-run-info db params))) (list (vector-ref res 0) (vector->list (vector-ref res 1))))) ((register-run) (apply db:register-run db params)) | | > > | 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 | ((get-prereqs-not-met) (apply db:get-prereqs-not-met params)) ;; RUNS ((get-run-info) (let ((res (apply db:get-run-info db params))) (list (vector-ref res 0) (vector->list (vector-ref res 1))))) ((register-run) (apply db:register-run db params)) ((set-tests-state-status) (apply db:set-tests-state-status db params)) ((get-tests-for-run) (map vector->list (apply db:get-tests-for-run db params))) ((get-test-id) (apply db:get-test-id-not-cached db params)) ((get-tests-for-runs-mindata) (map vector->list (apply db:get-tests-for-runs-mindata db params))) ((get-run-name-from-id) (apply db:get-run-name-from-id db params)) ((delete-run) (apply db:delete-run db params)) ((get-runs) (let* ((res (apply db:get-runs db params)) (hedr (vector-ref res 0)) (data (vector-ref res 1))) (list hedr (map vector->list data)))) ((get-runs-by-patt) (let* ((res (apply db:get-runs-by-patt db params)) (hedr (vector-ref res 0)) (data (vector-ref res 1))) (list hedr (map vector->list data)))) ((lock/unlock-run) (apply db:lock/unlock-run params)) ((update-run-event_time) (apply db:update-run-event_time params)) ;; MISC ((login) (apply db:login db params)) ((general-call) (let ((stmtname (car params)) (realparams (cdr params))) (db:general-call db stmtname realparams))) ((kill-server) |
︙ | ︙ | |||
79 80 81 82 83 84 85 | port: port) (set! *server-run* #f) (thread-sleep! 3) (if pid (process-signal pid signal/kill) (thread-start! th1)) '(#t "exit process started"))) | | > | 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 | port: port) (set! *server-run* #f) (thread-sleep! 3) (if pid (process-signal pid signal/kill) (thread-start! th1)) '(#t "exit process started"))) ((testmeta-add-record) (apply db:testmeta-add-record params)) ((testmeta-update-field) (apply db:testmeta-update-field params)) (else (list "ERROR" 0)))) ;; http-server send-response ;; api:process-request ;; db:* ;; |
︙ | ︙ |
Modified db.scm from [38f86aa7ed] to [b88b6ecfeb].
︙ | ︙ | |||
873 874 875 876 877 878 879 | (wildtype (if (substring-index "%" patt) "like" "glob"))) (if patt (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'")) (begin (debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey) (exit 6))))) keyvals) | | | 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 | (wildtype (if (substring-index "%" patt) "like" "glob"))) (if patt (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'")) (begin (debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey) (exit 6))))) keyvals) (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time " (if limit (conc " LIMIT " limit) "") (if offset (conc " OFFSET " offset) "") ";")) (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) (sqlite3:for-each-row (lambda (a . r) (set! res (cons (list->vector (cons a r)) res))) |
︙ | ︙ | |||
924 925 926 927 928 929 930 | db (lambda () (sqlite3:execute stmt1 run-id) (sqlite3:execute stmt2 run-id))) (sqlite3:finalize! stmt1) (sqlite3:finalize! stmt2))) (define (db:update-run-event_time db run-id) | < | < | 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 | db (lambda () (sqlite3:execute stmt1 run-id) (sqlite3:execute stmt2 run-id))) (sqlite3:finalize! stmt1) (sqlite3:finalize! stmt2))) (define (db:update-run-event_time db run-id) (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)) (define (db:lock/unlock-run db run-id lock unlock user) (let ((newlockval (if lock "locked" (if unlock "unlocked" "locked")))) ;; semi-failsafe (sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id) |
︙ | ︙ |
Modified rmt.scm from [3e2375dcb5] to [ac398979bc].
︙ | ︙ | |||
105 106 107 108 109 110 111 | (define (rmt:open-test-db-by-test-id test-id #!key (work-area #f)) (let* ((test-path (if (string? work-area) work-area (rmt:test-get-rundir-from-test-id test-id)))) (debug:print 3 "TEST PATH: " test-path) (open-test-db test-path))) | < < < < | 105 106 107 108 109 110 111 112 113 114 115 116 117 118 | (define (rmt:open-test-db-by-test-id test-id #!key (work-area #f)) (let* ((test-path (if (string? work-area) work-area (rmt:test-get-rundir-from-test-id test-id)))) (debug:print 3 "TEST PATH: " test-path) (open-test-db test-path))) ;; WARNING: This currently bypasses the transaction wrapped writes system (define (rmt:test-set-state-status-by-id test-id newstate newstatus newcomment) (rmt:send-receive 'test-set-state-status-by-id (list test-id newstate newstatus newcomment))) (define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus) (rmt:send-receive 'set-tests-state-status (list run-id testnames currstate currstatus newstate newstatus))) |
︙ | ︙ | |||
208 209 210 211 212 213 214 | (vector hedr (map list->vector data)))) (define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit) (let* ((res (rmt:send-receive 'get-runs-by-patt (list runpatt count offset keypatts))) (hedr (car res)) (data (cadr res))) (vector hedr (map list->vector data)))) | | > > > > > > | 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 | (vector hedr (map list->vector data)))) (define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit) (let* ((res (rmt:send-receive 'get-runs-by-patt (list runpatt count offset keypatts))) (hedr (car res)) (data (cadr res))) (vector hedr (map list->vector data)))) (define (rmt:lock/unlock-run run-id lock unlock user) (rmt:send-receive 'lock/unlock-run (list run-id lock unlock user))) (define (rmt:update-run-event_time run-id) (rmt:send-receive 'update-run-event_time (list run-id))) ;;====================================================================== ;; S T E P S ;;====================================================================== ;; Getting steps is more complicated. ;; ;; If given work area |
︙ | ︙ | |||
237 238 239 240 241 242 243 | ;;====================================================================== (define (rmt:read-test-data test-id categorypatt #!key (work-area #f)) (let ((tdb (rmt:open-test-db-by-test-id test-id work-area: work-area))) (if tdb (tdb:read-test-data tdb test-id categorypatt) '()))) | > > > > > > > > > > | 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 | ;;====================================================================== (define (rmt:read-test-data test-id categorypatt #!key (work-area #f)) (let ((tdb (rmt:open-test-db-by-test-id test-id work-area: work-area))) (if tdb (tdb:read-test-data tdb test-id categorypatt) '()))) (define (rmt:testmeta-add-record testname) (rmt:send-receive 'testmeta-add-record (list testname))) (define (rmt:testmeta-get-record testname) (list->vector (rmt:send-receive 'testmeta-get-record (list testname)))) (define (rmt:testmeta-update-field test-name fld val) (rmt:send-receive 'testmeta-update-field (list test-name fld val))) |
Modified runs.scm from [3f138f8523] to [9e4d65748b].
︙ | ︙ | |||
1353 1354 1355 1356 1357 1358 1359 | (let* ((dparts (string-split lasttpath "/")) (runpath (conc "/" (string-intersperse (take dparts (- (length dparts) 1)) "/")))) (debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record") (rmt:delete-run run-id) (rmt:delete-old-deleted-test-records) | | | 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 | (let* ((dparts (string-split lasttpath "/")) (runpath (conc "/" (string-intersperse (take dparts (- (length dparts) 1)) "/")))) (debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record") (rmt:delete-run run-id) (rmt:delete-old-deleted-test-records) ;; (cdb:remote-run db:set-var db "DELETED_TESTS" (current-seconds)) ;; need to figure out the path to the run dir and remove it if empty ;; (if (null? (glob (conc runpath "/*"))) ;; (begin ;; (debug:print 1 "Removing run dir " runpath) ;; (system (conc "rmdir -p " runpath)))) ))))) )) |
︙ | ︙ | |||
1435 1436 1437 1438 1439 1440 1441 | (for-each (lambda (run) (let ((run-id (db:get-value-by-header run header "id"))) (if (or lock (and unlock (begin (print "Do you really wish to unlock run " run-id "?\n y/n: ") (equal? "y" (read-line))))) | | | | | < > > | | | | | 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 | (for-each (lambda (run) (let ((run-id (db:get-value-by-header run header "id"))) (if (or lock (and unlock (begin (print "Do you really wish to unlock run " run-id "?\n y/n: ") (equal? "y" (read-line))))) (rmt:lock/unlock-run run-id lock unlock user) (debug:print-info 0 "Skipping lock/unlock on " run-id)))) runs))) ;;====================================================================== ;; Rollup runs ;;====================================================================== ;; Update the test_meta table for this test (define (runs:update-test_meta test-name test-conf) (let ((currrecord (rmt:testmeta-get-record test-name))) (if (not currrecord) (begin (set! currrecord (make-vector 10 #f)) (rmt:testmeta-add-record test-name))) (for-each (lambda (key) (let* ((idx (cadr key)) (fld (car key)) (val (config-lookup test-conf "test_meta" fld))) ;; (debug:print 5 "idx: " idx " fld: " fld " val: " val) (if (and val (not (equal? (vector-ref currrecord idx) val))) (begin (print "Updating " test-name " " fld " to " val) (rmt:testmeta-update-field test-name fld val))))) '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9))))) ;; Update test_meta for all tests (define (runs:update-all-test_meta db) (let ((test-names (tests:get-all))) ;; (tests:get-valid-tests))) (for-each (lambda (test-name) (let* ((test-conf (mt:lazy-read-test-config test-name))) (if test-conf (runs:update-test_meta test-name test-conf)))) (hash-table-keys test-names)))) ;; This could probably be refactored into one complex query ... ;; NOT PORTED - DO NOT USE YET ;; (define (runs:rollup-run keys runname user keyvals) (debug:print 4 "runs:rollup-run, keys: " keys " :runname " runname " user: " user) (let* ((db #f) (new-run-id (rmt:register-run keyvals runname "new" "n/a" user)) (prev-tests (rmt:get-matching-previous-test-run-records new-run-id "%" "%")) (curr-tests (mt:get-tests-for-run new-run-id "%/%" '() '())) (curr-tests-hash (make-hash-table))) (rmt:update-run-event_time new-run-id) ;; index the already saved tests by testname and itemdat in curr-tests-hash (for-each (lambda (testdat) (let* ((testname (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) (full-name (conc testname "/" item-path))) (hash-table-set! curr-tests-hash full-name testdat))) curr-tests) ;; NOPE: Non-optimal approach. Try this instead. ;; 1. tests are received in a list, most recent first ;; 2. replace the rollup test with the new *always* (for-each (lambda (testdat) (let* ((testname (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) (full-name (conc testname "/" item-path)) (prev-test-dat (hash-table-ref/default curr-tests-hash full-name #f)) (test-steps (rmt:get-steps-for-test (db:test-get-id testdat))) (new-test-record #f)) ;; replace these with insert ... select (apply sqlite3:execute db (conc "INSERT OR REPLACE INTO tests (run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) " "VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);") new-run-id (cddr (vector->list testdat))) |
︙ | ︙ |