Megatest

Diff
Login

Differences From Artifact [2542b667b5]:

To Artifact [2fe152a7f0]:


751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
    res))

;; get a useful subset of the tests data (used in dashboard
;; use db:mintests-get-{id ,run_id,testname ...}
(define (db:get-tests-for-runs-mindata db run-ids testpatt states status)
  (db:get-tests-for-runs db run-ids testpatt states status qryvals: "id,run_id,testname,state,status,event_time,item_path"))


;; NB // This is get tests for "runs" (note the plural!!)
;;
;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN
;; i.e. these lists define what to NOT show.
;; states and statuses are required to be lists, empty is ok
;; not-in #t = above behaviour, #f = must match
;; run-ids is a list of run-ids or a single number







<







751
752
753
754
755
756
757

758
759
760
761
762
763
764
    res))

;; get a useful subset of the tests data (used in dashboard
;; use db:mintests-get-{id ,run_id,testname ...}
(define (db:get-tests-for-runs-mindata db run-ids testpatt states status)
  (db:get-tests-for-runs db run-ids testpatt states status qryvals: "id,run_id,testname,state,status,event_time,item_path"))


;; NB // This is get tests for "runs" (note the plural!!)
;;
;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN
;; i.e. these lists define what to NOT show.
;; states and statuses are required to be lists, empty is ok
;; not-in #t = above behaviour, #f = must match
;; run-ids is a list of run-ids or a single number
1361
1362
1363
1364
1365
1366
1367
1368
1369


1370
1371
1372
1373
1374
1375
1376
	    (if (> cache-size *max-cache-size*)
		(set! *max-cache-size* cache-size)))
	  #t)
	#f)))

(define *db:process-queue-mutex* (make-mutex))

(define *number-of-writes*   0)
(define *writes-total-delay* 0)



;; The queue is a list of vectors where the zeroth slot indicates the type of query to
;; apply and the second slot is the time of the query and the third entry is a list of 
;; values to be applied
;;
(define (db:queue-write-and-wait db qry-sig query params)
  (let ((queue-len  0)







|
|
>
>







1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
	    (if (> cache-size *max-cache-size*)
		(set! *max-cache-size* cache-size)))
	  #t)
	#f)))

(define *db:process-queue-mutex* (make-mutex))

(define *number-of-writes*         0)
(define *writes-total-delay*       0)
(define *total-non-write-delay*    0)
(define *number-non-write-queries* 0)

;; The queue is a list of vectors where the zeroth slot indicates the type of query to
;; apply and the second slot is the time of the query and the third entry is a list of 
;; values to be applied
;;
(define (db:queue-write-and-wait db qry-sig query params)
  (let ((queue-len  0)
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
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
			  (else  
			   (apply sqlite3:execute db query params)
			   #t))))
	  (debug:print-info 7 "Received " response " from wrapped write")
	  (server:reply return-address qry-sig response response))
	;; otherwise if appropriate flush the queue (this is a read or complex query)
	(begin
	  (case *transport-type*
	    ((http)
	  (mutex-lock! *db:process-queue-mutex*)
	  (db:process-cached-writes db)
	  (mutex-unlock! *db:process-queue-mutex*)))
	  (cond
	   ((member stmt-key db:special-queries)

	    (debug:print-info 11 "Handling special statement " stmt-key)
	    (case stmt-key
	      ((immediate)






	       (let ((proc      (car params))
		     (remparams (cdr params)))
		 ;; we are being handed a procedure so call it
		 (debug:print-info 11 "Running (apply " proc " " remparams ")")
		 (server:reply return-address qry-sig #t (apply proc remparams))))



	      ((login)
	       (if (< (length params) 3) ;; should get toppath, version and signature
		   (server:reply return-address qry-sig '(#f "login failed due to missing params")) ;; missing params
		   (let ((calling-path (car   params))
			 (calling-vers (cadr  params))
			 (client-key   (caddr params)))
		     (if (and (equal? calling-path *toppath*)
			      (equal? megatest-version calling-vers))
			 (begin
			   (hash-table-set! *logged-in-clients* client-key (current-seconds))
			   (server:reply return-address qry-sig #t '(#t "successful login")))      ;; path matches - pass! Should vet the caller at this time ...
			 (server:reply return-address qry-sig #f (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*)))))))
	      ((flush sync)
	       (server:reply return-address qry-sig #t 1)) ;; (length data)))
	      ((set-verbosity)
	       (set! *verbosity* (car params))
	       (server:reply return-address qry-sig #t '(#t *verbosity*)))
	      ((killserver)
	       (debug:print 0 "WARNING: Server going down in 15 seconds by user request!")
	       (open-run-close tasks:server-deregister tasks:open-db 
			       (car *runremote*)
			       pullport: (cadr *runremote*))
	       (thread-start! (make-thread (lambda ()(thread-sleep! 15)(exit))))
	       (server:reply return-address qry-sig #t '(#t "exit process started")))
	      (else ;; not a command, i.e. is a query
	       (debug:print 0 "ERROR: Unrecognised query/command " stmt-key)
	       (server:reply pubsock return-address qry-sig #f 'failed))))
	   (else
	    (debug:print-info 11 "Executing " stmt-key " for " params)
	    (apply sqlite3:execute (hash-table-ref queries stmt-key) params)
	    (server:reply return-address qry-sig #t #t)))))))

(define (db:test-get-records-for-index-file db run-id test-name)
  (let ((res '()))







<
<
<
<
<


>
|
|
|
>
>
>
>
>
>
|
|
|
|
|
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







1424
1425
1426
1427
1428
1429
1430





1431
1432
1433
1434
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
			  (else  
			   (apply sqlite3:execute db query params)
			   #t))))
	  (debug:print-info 7 "Received " response " from wrapped write")
	  (server:reply return-address qry-sig response response))
	;; otherwise if appropriate flush the queue (this is a read or complex query)
	(begin





	  (cond
	   ((member stmt-key db:special-queries)
	    (let ((starttime (current-milliseconds)))
	      (debug:print-info 11 "Handling special statement " stmt-key)
	      (case stmt-key
		((immediate)
		 ;; This is a read or mixed read-write query, must clear the cache
		 (case *transport-type*
		   ((http)
		    (mutex-lock! *db:process-queue-mutex*)
		    (db:process-cached-writes db)
		    (mutex-unlock! *db:process-queue-mutex*)))
		 (let* ((proc      (car params))
			(remparams (cdr params))
			;; we are being handed a procedure so call it
			;; (debug:print-info 11 "Running (apply " proc " " remparams ")")
			(result (server:reply return-address qry-sig #t (apply proc remparams))))
		   (set! *total-non-write-delay* (+ *total-non-write-delay* (- (current-milliseconds) starttime))) 
		   (set! *number-non-write-queries* (+ *number-non-write-queries* 1))
		   result))
		((login)
		 (if (< (length params) 3) ;; should get toppath, version and signature
		     (server:reply return-address qry-sig '(#f "login failed due to missing params")) ;; missing params
		     (let ((calling-path (car   params))
			   (calling-vers (cadr  params))
			   (client-key   (caddr params)))
		       (if (and (equal? calling-path *toppath*)
				(equal? megatest-version calling-vers))
			   (begin
			     (hash-table-set! *logged-in-clients* client-key (current-seconds))
			     (server:reply return-address qry-sig #t '(#t "successful login")))      ;; path matches - pass! Should vet the caller at this time ...
			   (server:reply return-address qry-sig #f (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*)))))))
		((flush sync)
		 (server:reply return-address qry-sig #t 1)) ;; (length data)))
		((set-verbosity)
		 (set! *verbosity* (car params))
		 (server:reply return-address qry-sig #t '(#t *verbosity*)))
		((killserver)
		 (debug:print 0 "WARNING: Server going down in 15 seconds by user request!")
		 (open-run-close tasks:server-deregister tasks:open-db 
				 (car *runremote*)
				 pullport: (cadr *runremote*))
		 (thread-start! (make-thread (lambda ()(thread-sleep! 15)(exit))))
		 (server:reply return-address qry-sig #t '(#t "exit process started")))
		(else ;; not a command, i.e. is a query
		 (debug:print 0 "ERROR: Unrecognised query/command " stmt-key)
		 (server:reply return-address qry-sig #f 'failed)))))
	   (else
	    (debug:print-info 11 "Executing " stmt-key " for " params)
	    (apply sqlite3:execute (hash-table-ref queries stmt-key) params)
	    (server:reply return-address qry-sig #t #t)))))))

(define (db:test-get-records-for-index-file db run-id test-name)
  (let ((res '()))