| ︙ | | |
20
21
22
23
24
25
26
27
28
29
30
31
32
33
|
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
+
+
|
(use format typed-records) ;; RADT => purpose of json format??
(declare (unit rmt))
(declare (uses api))
(declare (uses http-transport))
(include "common_records.scm")
(include "db_records.scm")
;; (declare (uses rmtmod))
;; (import rmtmod)
;;
;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!
;;
|
| ︙ | | |
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
|
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
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
|
cinfo
(if (server:check-if-running areapath)
(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)
(let* ((now (current-milliseconds)))
(cond
((> (- now *rmt-query-last-call-time*) 500) ;; 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 1/2 second.")
(thread-sleep! 0.5) ;; 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))
|
| ︙ | | |
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
|
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
|
-
+
-
+
+
+
+
+
+
+
+
+
+
|
;; 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)))
(trundatf (conc (db:test-get-rundir testdat) "/.mt_data/test-run.dat")))
;; now we can update a couple fields from the filesystem
(if (and (db:test-get-rundir testdat)
(file-exists? trundatf))
(let* ((duration (db:test-get-run_duration testdat))
(event-time (db:test-get-event_time testdat))
(last-touch (file-modification-time trundatf)))
(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)))
|
| ︙ | | |
925
926
927
928
929
930
931
932
933
934
935
936
937
938
|
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
|
+
+
+
+
+
+
+
+
+
|
(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)))
|
| ︙ | | |