| ︙ | | |
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
|
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
|
(client:setup areapath)
#f))))
;;======================================================================
(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id
(define *rmt-query-last-call-time* 0)
(define *rmt-query-last-rest-time* 0) ;; last time there was at least a 1/2 second rest - giving other processes access to the db
;; NOTE: This query rest algorythm will not adapt to long query times. REDESIGN NEEDED. TODO. FIXME.
;;
(define (rmt:query-rest cmd rid params)
(let* ((now (current-milliseconds)))
(cond
((> (- now *rmt-query-last-call-time*) 100) ;; it's been a while since last query - no need to rest
(set! *rmt-query-last-rest-time* now)
(set! *rmt-query-last-call-time* now))
((> (- now *rmt-query-last-rest-time*) 5000) ;; no natural rests have happened
(debug:print 0 *default-log-port* "query rest needed. blocking for 0.1 second. cmd="cmd", run id="rid", params="params)
(thread-sleep! 0.1) ;; force a rest of a half second
(set! *rmt-query-last-rest-time* now)
(set! *rmt-query-last-call-time* now))
(else ;; sufficient rests have occurred, just record the last query time
(set! *rmt-query-last-call-time* now)))))
;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname))
;;
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected
#;(common:telemetry-log (conc "rmt:"(->string cmd))
payload: `((rid . ,rid)
(params . ,params)))
(if (not (equal? (configf:lookup *configdat* "setup" "query-rest") "no"))
(rmt:query-rest cmd rid params))
|
| ︙ | | |
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
|
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
|
-
+
|
#f))
(begin
;; (rmt:update-db-stats run-id cmd params duration)
;; mark this run as dirty if this was a write, the watchdog is responsible for syncing it
(if qry-is-write
(let ((start-time (current-seconds)))
(mutex-lock! *db-multi-sync-mutex*)
/ (set! *db-last-access* start-time) ;; THIS IS PROBABLY USELESS? (we are on a client)
|
| ︙ | | |
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
|
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
|
-
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;; Just some syntatic sugar
(define (rmt:register-test run-id test-name item-path)
(rmt:general-call 'register-test run-id run-id test-name item-path))
(define (rmt:get-test-id run-id testname item-path)
(rmt:send-receive 'get-test-id run-id (list run-id testname item-path)))
;; run-id is NOT used
;; run-id is NOT used - but it will be!
;;
(define (rmt:get-test-info-by-id run-id test-id)
(if (number? test-id)
(rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id))
(let* ((testdat (rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id)))
(trundir (vector-ref testdat 10))
(trundatf (conc trundir"/.mt_data/test-run.dat")))
;; now we can update a couple fields from the filesystem
(handle-exceptions
exn
(begin
(debug:print-info 0 *default-log-port* "Could not update testdat record from "trundatf", exn=" exn)
#f)
(if (and trundir
(file-exists? trundatf))
(let* ((duration (vector-ref testdat 12)) ;; (db:test-get-run_duration testdat))
(event-time (vector-ref testdat 5)) ;; (db:test-get-event_time testdat))
(last-touch (file-modification-time trundatf))
(new-duration (max duration (- last-touch event-time))))
(vector-set! testdat 12 new-duration))))
#;(db:test-set-run_duration! testdat (max duration (- last-touch event-time)))
testdat)
(begin
(debug:print 0 *default-log-port* "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id)
(print-call-chain (current-error-port))
#f)))
(define (rmt:test-get-rundir-from-test-id run-id test-id)
(rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id)))
|
| ︙ | | |
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
|
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
|
+
-
+
+
|
(rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname)))
run-ids))))
(define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f))
(rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-test-name ref-item-path mode itemmaps)))
(define (rmt:get-count-tests-running-for-run-id run-id)
(if (number? run-id)
(rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id)))
(rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id))
0))
(define (rmt:get-not-completed-cnt run-id)
(rmt:send-receive 'get-not-completed-cnt run-id (list run-id)))
;; Statistical queries
|
| ︙ | | |
943
944
945
946
947
948
949
950
951
952
953
954
955
956
|
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
|
+
+
+
+
+
+
+
+
+
|
(rmt:send-receive 'no-sync-get/default #f `(,var ,default)))
(define (rmt:no-sync-del! var)
(rmt:send-receive 'no-sync-del! #f `(,var)))
(define (rmt:no-sync-get-lock keyname)
(rmt:send-receive 'no-sync-get-lock #f `(,keyname)))
(define (rmt:no-sync-add-job host-type vars-list exekey cmdline)
(rmt:send-receive 'no-sync-add-job #f `(,host-type ,vars-list ,exekey ,cmdline)))
(define (rmt:no-sync-take-job host-type)
(rmt:send-receive 'no-sync-take-job #f `(,host-type)))
(define (rmt:no-sync-job-records-clean)
(rmt:set-receive 'no-sync-job-records-clean #f '()))
;;======================================================================
;; A R C H I V E S
;;======================================================================
(define (rmt:archive-get-allocations testname itempath dneeded)
(rmt:send-receive 'archive-get-allocations #f (list testname itempath dneeded)))
|
| ︙ | | |