Megatest

Check-in [78a6fc6609]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:test4 passes 100% with rpc
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | test-specific-db
Files: files | file ages | folders
SHA1: 78a6fc6609f878d5ead40caca362f3a849075689
User & Date: matt on 2012-10-06 19:08:27
Other Links: branch diff | manifest | tags
Context
2012-10-06
19:49
corrected iterated to test_data in tests.scm for test1. check-in: e1cd100b2d user: mrwellan tags: test-specific-db, v1.4609
19:08
test4 passes 100% with rpc check-in: 78a6fc6609 user: matt tags: test-specific-db
16:40
rpc working on Ubuntu except for rollup check-in: 6747bc6633 user: matt tags: test-specific-db
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified common.scm from [da51601b6b] to [b1035eae27].

︙
38
39
40
41
42
43
44
45


46
47
48
49
50
51
52

38
39
40
41
42
43
44

45
46
47
48
49
50
51
52
53








-
+
+








(define *waiting-queue*     (make-hash-table))
(define *test-meta-updated* (make-hash-table))
(define *globalexitstatus*  0) ;; attempt to work around possible thread issues
(define *passnum*           0) ;; when running track calls to run-tests or similar
(define *verbosity*         1)
(define *rpc:listener*      #f) ;; if set up for server communication this will hold the tcp port
(define *runremote*         #f) ;; if set up for server communication this will hold <host port>
(define *last-db-access*    0)  ;; update when db is accessed via server
(define *last-db-access*    (current-seconds))  ;; update when db is accessed via server
(define *max-cache-size*    0)
(define *target*            (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN
(define *keys*              (make-hash-table)) ;; cache the keys here
(define *keyvals*           (make-hash-table))
(define *toptest-paths*     (make-hash-table)) ;; cache toptest path settings here
(define *test-paths*        (make-hash-table)) ;; cache test-id to test run paths here
(define *test-ids*          (make-hash-table)) ;; cache run-id, testname, and item-path => test-id
(define *test-info*         (make-hash-table)) ;; cache the test info records, update the state, status, run_duration etc. from testdat.db
︙

Modified db.scm from [a974e4f201] to [f499d2e56f].

︙
1045
1046
1047
1048
1049
1050
1051
1052
1053


1054
1055
1056

1057
1058
1059
1060
1061
1062
1063

1045
1046
1047
1048
1049
1050
1051


1052
1053
1054
1055

1056
1057
1058
1059
1060
1061
1062
1063








-
-
+
+


-
+








					  (list state status test-id)) ;; run-id test-name item-path minutes cpuload diskfree tmpfree) 
				  *incoming-data*)))
  (mutex-unlock! *incoming-mutex*)
  (if *cache-on*
      (debug:print 6 "INFO: *cache-on* is " *cache-on* ", skipping cache write")
      (db:write-cached-data)))
  
(define (cdb:test-rollup-iterated-pass-fail test-id)
  (debug:print 4 "INFO: Adding " test-id " for iterated rollup to the queue")
(define (cdb:test-rollup-test_data-pass-fail test-id)
  (debug:print 4 "INFO: Adding " test-id " for test_data rollup to the queue")
  (mutex-lock! *incoming-mutex*)
  (set! *last-db-access* (current-seconds))
  (set! *incoming-data* (cons (vector 'iterated-p/f-rollup
  (set! *incoming-data* (cons (vector 'test_data-pf-rollup
				      (current-milliseconds)
				      (list test-id test-id test-id test-id))
			      *incoming-data*))
  (mutex-unlock! *incoming-mutex*)
  (if *cache-on*
      (debug:print 6 "INFO: *cache-on* is " *cache-on* ", skipping cache write")
      (db:write-cached-data)))
︙
1098
1099
1100
1101
1102
1103
1104
1105

1106
1107
1108
1109
1110
1111
1112
1113


1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133



1134

1135
1136
1137
1138
1139
1140





1141
1142
1143

1144
1145


1146

1147
1148
1149
1150
1151
1152

1153
1154
1155
1156
1157
1158
1159

1098
1099
1100
1101
1102
1103
1104

1105
1106
1107
1108
1109
1110
1111
1112

1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132


1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150

1151
1152
1153
1154
1155

1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170








-
+







-
+
+


















-
-
+
+
+

+






+
+
+
+
+


-
+


+
+
-
+






+








(define (db:write-cached-data)
  (open-run-close
   (lambda (db . params)
     (let ((register-test-stmt    (sqlite3:prepare db "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');"))
	   (state-status-stmt     (sqlite3:prepare db "UPDATE tests SET state=?,status=? WHERE id=?;"))
	   (state-status-msg-stmt (sqlite3:prepare db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;"))
	   (pass-fail-counts-stmt (sqlite3:prepare db "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;"))
	   (iterated-rollup-stmt  (sqlite3:prepare db "UPDATE tests
	   (test_data-rollup-stmt  (sqlite3:prepare db "UPDATE tests
                                             SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 
                                                THEN 'FAIL'
                                             WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND 
                                                  (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL')
                                             THEN 'PASS'
                                             ELSE status
                                         END WHERE id=?;"))
	   (data                  #f))
	   (data                  #f)
	   (rollups               (make-hash-table)))
       (mutex-lock! *incoming-mutex*)
       (set! data (sort *incoming-data* (lambda (a b)(< (vector-ref a 1)(vector-ref b 1)))))
       (set! *incoming-data* '())
       (mutex-unlock! *incoming-mutex*)
       (if (> (length data) 0)
	   (debug:print 4 "INFO: Writing cached data " data))
       (sqlite3:with-transaction 
	db
	(lambda ()
	  (debug:print 4 "INFO: flushing " data " to db")
	  (for-each (lambda (entry)
		      (let ((params (vector-ref entry 2)))
			(debug:print 4 "INFO: Applying " entry " to params " params)
			(case (vector-ref entry 0)
			  ((state-status)
			   (apply sqlite3:execute state-status-stmt     params))
			  ((state-status-msg)
			   (apply sqlite3:execute state-status-msg-stmt params))
			  ((iterated-p/f-rollup)
			   (apply sqlite3:execute iterated-rollup-stmt  params))
			  ((test_data-pf-rollup)
			   ;; (hash-table-set! rollups (car params) params))
			   (apply sqlite3:execute test_data-rollup-stmt  params))
			  ((pass-fail-counts)
			   (debug:print 0 "INFO: pass fail count params are " params)
			   (apply sqlite3:execute pass-fail-counts-stmt params))
			  ((register-test)
			   (apply sqlite3:execute register-test-stmt    params))
			  (else
			   (debug:print 0 "ERROR: Queued entry not recognised " entry)))))
		    data)))
       ;; now do any rollups
       ;; (for-each
       ;;  (lambda (test-id)
       ;;    (apply sqlite3:execute test_data-rollup-stmt (hash-table-ref rollups test-id)))
       ;;  (hash-table-keys rollups))
       (sqlite3:finalize! state-status-stmt)
       (sqlite3:finalize! state-status-msg-stmt)
       (sqlite3:finalize! iterated-rollup-stmt)
       (sqlite3:finalize! test_data-rollup-stmt)
       (sqlite3:finalize! pass-fail-counts-stmt)
       (sqlite3:finalize! register-test-stmt)
       (let ((cache-size (length data)))
	 (if (> cache-size *max-cache-size*)
       ;; (set! *last-db-access* (current-seconds))
	     (set! *max-cache-size* cache-size)))
       ))
   #f))

(define cdb:flush-queue db:write-cached-data)

(define (db:roll-up-pass-fail-counts db run-id test-name item-path status)
  (rdb:flush-queue)
  (if (and (not (equal? item-path ""))
	   (or (equal? status "PASS")
	       (equal? status "WARN")
	       (equal? status "FAIL")
	       (equal? status "WAIVED")
	       (equal? status "RUNNING")))
      (begin
︙
1312
1313
1314
1315
1316
1317
1318
1319

1320
1321
1322

1323
1324
1325
1326
1327
1328
1329

1323
1324
1325
1326
1327
1328
1329

1330
1331
1332

1333
1334
1335
1336
1337
1338
1339
1340








-
+


-
+








	  (sqlite3:finalize! tdb)

	  ;; Now rollup the counts to the central megatest.db
	  (rdb:pass-fail-counts test-id fail-count pass-count)
	  ;; (sqlite3:execute db "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;" 
	  ;;                     fail-count pass-count test-id)

	  (thread-sleep! 0.01) ;; play nice with the queue by ensuring the rollup is at least 10ms later than the set
	  (thread-sleep! 10) ;; play nice with the queue by ensuring the rollup is at least 10s later than the set
	  
	  ;; if the test is not FAIL then set status based on the fail and pass counts.
	  (rdb:test-rollup-iterated-pass-fail test-id)
	  (rdb:test-rollup-test_data-pass-fail test-id)
	  ;; (sqlite3:execute
	  ;;  db   ;;; NOTE: Should this be WARN,FAIL? A WARN is not a FAIL????? BUG FIXME
	  ;;  "UPDATE tests
          ;;             SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 
          ;;                THEN 'FAIL'
          ;;             WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND 
          ;;                  (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL')
︙
1638
1639
1640
1641
1642
1643
1644
1645

1646
1647
1648
1649
1650


1651
1652
1653
1654
1655
1656
1657

1649
1650
1651
1652
1653
1654
1655

1656
1657
1658
1659


1660
1661
1662
1663
1664
1665
1666
1667
1668








-
+



-
-
+
+








	   (debug:print 0 "EXCEPTION: rpc call failed?")
	   (debug:print 0 "  " ((condition-property-accessor 'exn 'message) exn))
	   (print-call-chain)
	   (cdb:test-set-status-state test-id status state msg))
	 ((rpc:procedure 'cdb:test-set-status-state host port) test-id status state msg)))
      (cdb:test-set-status-state test-id status state msg)))

(define (rdb:test-rollup-iterated-pass-fail test-id)
(define (rdb:test-rollup-test_data-pass-fail test-id)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'cdb:test-rollup-iterated-pass-fail host port) test-id))
      (cdb:test-rollup-iterated-pass-fail test-id)))
	((rpc:procedure 'cdb:test-rollup-test_data-pass-fail host port) test-id))
      (cdb:test-rollup-test_data-pass-fail test-id)))

(define (rdb:pass-fail-counts test-id fail-count pass-count)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'cdb:pass-fail-counts host port) test-id fail-count pass-count))
      (cdb:pass-fail-counts test-id fail-count pass-count)))
︙

Modified server.scm from [ad03b1f127] to [e3a9a59227].

︙
88
89
90
91
92
93
94
95

96
97
98


99
100
101
102
103
104
105

88
89
90
91
92
93
94

95
96


97
98
99
100
101
102
103
104
105








-
+

-
-
+
+








	  (rpc:publish-procedure!
	   'cdb:test-set-status-state
	   (lambda (test-id status state msg)
	     (debug:print 4 "INFO: Remote call of cdb:test-set-status-state test-id=" test-id ", status=" status ", state=" state ", msg=" msg)
	     (cdb:test-set-status-state test-id status state msg)))

	  (rpc:publish-procedure!
	   'cdb:test-rollup-iterated-pass-fail
	   'cdb:test-rollup-test_data-pass-fail
	   (lambda (test-id)
	     (debug:print 4 "INFO: Remote call of cdb:test-rollup-iterated-pass-fail " test-id)
	     (cdb:test-rollup-iterated-pass-fail test-id)))
	     (debug:print 4 "INFO: Remote call of cdb:test-rollup-test_data-pass-fail " test-id)
	     (cdb:test-rollup-test_data-pass-fail test-id)))

	  (rpc:publish-procedure!
	   'cdb:pass-fail-counts
	   (lambda (test-id fail-count pass-count)
	     (debug:print 4 "INFO: Remote call of cdb:pass-fail-counts " test-id " passes: " pass-count " fails: " fail-count)
	     (cdb:pass-fail-counts test-id fail-count pass-count)))
︙
154
155
156
157
158
159
160

161
162
163
164
165
166
167

154
155
156
157
158
159
160
161
162
163
164
165
166
167
168








+








      (if (or (not (> numrunning 0))
	      (> *last-db-access* (+ (current-seconds) 60)))
	  (begin
	    (debug:print 0 "INFO: Starting to shutdown the server side")
	    ;; need to delete only *my* server entry (future use)
	    (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER' AND val like ?;"  host:port)
	    (thread-sleep! 10)
	    (debug:print 0 "INFO: Max cached queries was " *max-cache-size*)
	    (debug:print 0 "INFO: Server shutdown complete. Exiting")
	    (exit))
	  (debug:print 0 "INFO: Server continuing, tests running: " numrunning ", seconds since last db access: " (- (current-seconds) *last-db-access*))
	  ))
    (loop (+ 1 count))))

(define (server:find-free-port-and-open port)
︙

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