Megatest

Diff
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Annotate Patch Side-by-side Diff

Differences From Artifact [7a89b7f1fc]:

To Artifact [887b32b0da]:

︙
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30

15
16
17
18
19
20
21


22
23
24
25
26
27
28








-
-









(require-extension (srfi 18) extras tcp) ;;  rpc)
;; (import (prefix rpc rpc:))

(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest)
(import (prefix sqlite3 sqlite3:))

(use zmq)

(declare (unit db))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))

(include "common_records.scm")
(include "db_records.scm")
︙
781
782
783
784
785
786
787
788
789


790
791
792
793
794
795
796

779
780
781
782
783
784
785


786
787
788
789
790
791
792
793
794








-
-
+
+








			       (if currstate  (conc "state='" currstate "' AND ") "")
			       (if currstatus (conc "status='" currstatus "' AND ") "")
			       " run_id=? AND testname=? AND NOT (item_path='' AND testname in (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")))
		;;(debug:print 0 "QRY: " qry)
		(sqlite3:execute db qry run-id newstate newstatus testname testname)))
	    testnames))

(define (cdb:delete-tests-in-state zmqsocket run-id state)
  (cdb:client-call zmqsocket 'delete-tests-in-state #t *default-numtries* run-id state))
(define (cdb:delete-tests-in-state serverdat run-id state)
  (cdb:client-call serverdat 'delete-tests-in-state #t *default-numtries* run-id state))

;; speed up for common cases with a little logic
(define (db:test-set-state-status-by-id db test-id newstate newstatus newcomment)
  (cond
   ((and newstate newstatus newcomment)
    (sqlite3:exectute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus test-id))
   ((and newstate newstatus)
︙
960
961
962
963
964
965
966
967
968


969
970
971


972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988


989
990
991
992
993
994
995

958
959
960
961
962
963
964


965
966
967


968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984


985
986
987
988
989
990
991
992
993








-
-
+
+

-
-
+
+















-
-
+
+









(define (db:test-set-comment db test-id comment)
  (sqlite3:execute 
   db 
   "UPDATE tests SET comment=? WHERE id=?;"
   comment test-id))

(define (cdb:test-set-rundir! zmqsocket run-id test-name item-path rundir)
  (cdb:client-call zmqsocket 'test-set-rundir #t *default-numtries* rundir run-id test-name item-path))
(define (cdb:test-set-rundir! serverdat run-id test-name item-path rundir)
  (cdb:client-call serverdat 'test-set-rundir #t *default-numtries* rundir run-id test-name item-path))

(define (cdb:test-set-rundir-by-test-id zmqsocket test-id rundir)
  (cdb:client-call zmqsocket 'test-set-rundir-by-test-id #t *default-numtries* rundir test-id))
(define (cdb:test-set-rundir-by-test-id serverdat test-id rundir)
  (cdb:client-call serverdat 'test-set-rundir-by-test-id #t *default-numtries* rundir test-id))

(define (db:test-get-rundir-from-test-id db test-id)
  (let ((res #f)) ;; (hash-table-ref/default *test-paths* test-id #f)))
    ;; (if res
    ;;     res
    ;;     (begin
    (sqlite3:for-each-row
     (lambda (tpath)
       (set! res tpath))
     db 
     "SELECT rundir FROM tests WHERE id=?;"
     test-id)
    ;; (hash-table-set! *test-paths* test-id res)
    res)) ;; ))

(define (cdb:test-set-log! zmqsocket test-id logf)
  (if (string? logf)(cdb:client-call zmqsocket 'test-set-log #f *default-numtries* logf test-id)))
(define (cdb:test-set-log! serverdat test-id logf)
  (if (string? logf)(cdb:client-call serverdat 'test-set-log #f *default-numtries* logf test-id)))

;;======================================================================
;; Misc. test related queries
;;======================================================================

(define (db:test-get-paths-matching db keynames target fnamepatt #!key (res '()))
  (let* ((testpatt   (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%"))
︙
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
1171


1172
1173
1174


1175
1176
1177


1178
1179

1180
1181
1182


1183
1184
1185


1186
1187
1188


1189
1190

1191
1192
1193
1194

1195
1196
1197


1198
1199
1200


1201
1202
1203


1204
1205
1206


1207
1208
1209


1210
1211
1212
1213
1214
1215
1216

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

1171
1172


1173
1174
1175


1176
1177
1178


1179
1180
1181

1182
1183
1184
1185

1186
1187


1188
1189
1190


1191
1192
1193


1194
1195
1196


1197
1198
1199


1200
1201
1202
1203
1204
1205
1206
1207
1208








-
-
+
+




-
+
-
-
-
+




-
-
-
-
+



-

-
+


-
+











-
+












-
-
+
+

-
-
+
+

-
-
+
+

-
-
+
+

-
+

-
-
+
+

-
-
+
+

-
-
+
+

-
+



-
+

-
-
+
+

-
-
+
+

-
-
+
+

-
-
+
+

-
-
+
+








    (set! *client-non-blocking-mode* #f)
    res))
  
;; params = 'target cached remparams
;;
;; make-vector-record cdb packet client-sig qtype immediate query-sig params qtime
;;
(define (cdb:client-call zmq-sockets qtype immediate numretries . params)
  (debug:print-info 11 "cdb:client-call zmq-sockets=" zmq-sockets ", qtype=" qtype ", immediate=" immediate ", numretries=" numretries ", params=" params)
(define (cdb:client-call serverdat qtype immediate numretries . params)
  (debug:print-info 11 "cdb:client-call serverdat=" serverdat ", qtype=" qtype ", immediate=" immediate ", numretries=" numretries ", params=" params)
  (handle-exceptions
   exn
   (begin
     (thread-sleep! 5) 
     (if (> numretries 0)(apply cdb:client-call zmq-sockets qtype immediate (- numretries 1) params)))
     (if (> numretries 0)(apply cdb:client-call serverdat qtype immediate (- numretries 1) params)))
   (let* ((push-socket (vector-ref zmq-sockets 0))
	  (sub-socket  (vector-ref zmq-sockets 1))
	  (client-sig  (server:get-client-signature))
   (let* ((client-sig  (server:get-client-signature))
	  (query-sig   (message-digest-string (md5-primitive) (conc qtype immediate params)))
	  (zdat        (db:obj->string (vector client-sig qtype immediate query-sig params (current-seconds)))) ;; (with-output-to-string (lambda ()(serialize params))))
	  (res  #f)
	  (send-receive (lambda ()
			  (debug:print-info 11 "sending message")
			  (send-message push-socket zdat)
			  (debug:print-info 11 "message sent")
			  (let loop ()
			  (let loop ((res (server:client-send-receive serverdat zdat)))
			    ;; get the sender info
			    ;; this should match (server:get-client-signature)
			    ;; we will need to process "all" messages here some day
			    (receive-message* sub-socket)
			    ;; now get the actual message
			    (let ((myres (db:string->obj (receive-message* sub-socket))))
			    (let ((myres (db:string->obj res)))
			      (if (equal? query-sig (vector-ref myres 1))
				  (set! res (vector-ref myres 2))
				  (loop))))))
				  (loop (server:client-send-receive serverdat zdat)))))))
	  (timeout (lambda ()
		     (let loop ((n numretries))
		       (thread-sleep! 15)
		       (if (not res)
			   (if (> numretries 0)
			       (begin
				 (debug:print 2 "WARNING: no reply to query " params ", trying resend")
				 (debug:print-info 11 "re-sending message")
				 (send-message push-socket zdat)
				 (debug:print-info 11 "message re-sent")
				 (loop (- n 1)))
			       ;; (apply cdb:client-call zmq-sockets qtype immediate (- numretries 1) params))
			       ;; (apply cdb:client-call serverdats qtype immediate (- numretries 1) params))
			       (begin
				 (debug:print 0 "ERROR: cdb:client-call timed out " params ", exiting.")
				 (exit 5))))))))
     (debug:print-info 11 "Starting threads")
     (let ((th1 (make-thread send-receive "send receive"))
	   (th2 (make-thread timeout      "timeout")))
       (thread-start! th1)
       (thread-start! th2)
       (thread-join!  th1)
       (debug:print-info 11 "cdb:client-call returning res=" res)
       res))))
  
(define (cdb:set-verbosity zmq-socket val)
  (cdb:client-call zmq-socket 'set-verbosity #f *default-numtries* val))
(define (cdb:set-verbosity serverdat val)
  (cdb:client-call serverdat 'set-verbosity #f *default-numtries* val))

(define (cdb:login zmq-sockets keyval signature)
  (cdb:client-call zmq-sockets 'login #t *default-numtries* keyval megatest-version signature))
(define (cdb:login serverdat keyval signature)
  (cdb:client-call serverdat 'login #t *default-numtries* keyval megatest-version signature))

(define (cdb:logout zmq-socket keyval signature)
  (cdb:client-call zmq-socket 'logout #t *default-numtries* keyval signature))
(define (cdb:logout serverdat keyval signature)
  (cdb:client-call serverdat 'logout #t *default-numtries* keyval signature))

(define (cdb:num-clients zmq-socket)
  (cdb:client-call zmq-socket 'numclients #t *default-numtries*))
(define (cdb:num-clients serverdat)
  (cdb:client-call serverdat 'numclients #t *default-numtries*))

(define (cdb:test-set-status-state zmqsocket test-id status state msg)
(define (cdb:test-set-status-state serverdat test-id status state msg)
  (if msg
      (cdb:client-call zmqsocket 'state-status-msg #t *default-numtries* state status msg test-id)
      (cdb:client-call zmqsocket 'state-status #t *default-numtries* state status test-id))) ;; run-id test-name item-path minutes cpuload diskfree tmpfree) 
      (cdb:client-call serverdat 'state-status-msg #t *default-numtries* state status msg test-id)
      (cdb:client-call serverdat 'state-status #t *default-numtries* state status test-id))) ;; run-id test-name item-path minutes cpuload diskfree tmpfree) 

(define (cdb:test-rollup-test_data-pass-fail zmqsocket test-id)
  (cdb:client-call zmqsocket 'test_data-pf-rollup #t *default-numtries* test-id test-id test-id test-id))
(define (cdb:test-rollup-test_data-pass-fail serverdat test-id)
  (cdb:client-call serverdat 'test_data-pf-rollup #t *default-numtries* test-id test-id test-id test-id))

(define (cdb:pass-fail-counts zmqsocket test-id fail-count pass-count)
  (cdb:client-call zmqsocket 'pass-fail-counts #t *default-numtries* fail-count pass-count test-id))
(define (cdb:pass-fail-counts serverdat test-id fail-count pass-count)
  (cdb:client-call serverdat 'pass-fail-counts #t *default-numtries* fail-count pass-count test-id))

(define (cdb:tests-register-test zmqsocket run-id test-name item-path)
(define (cdb:tests-register-test serverdat run-id test-name item-path)
  (let ((item-paths (if (equal? item-path "")
			(list item-path)
			(list item-path ""))))
    (cdb:client-call zmqsocket 'register-test #t *default-numtries* run-id test-name item-path)))
    (cdb:client-call serverdat 'register-test #t *default-numtries* run-id test-name item-path)))

(define (cdb:flush-queue zmqsocket)
  (cdb:client-call zmqsocket 'flush #f *default-numtries*))
(define (cdb:flush-queue serverdat)
  (cdb:client-call serverdat 'flush #f *default-numtries*))

(define (cdb:kill-server zmqsocket)
  (cdb:client-call zmqsocket 'killserver #f *default-numtries*))
(define (cdb:kill-server serverdat)
  (cdb:client-call serverdat 'killserver #f *default-numtries*))

(define (cdb:roll-up-pass-fail-counts zmqsocket run-id test-name item-path status)
  (cdb:client-call zmqsocket 'immediate #f *default-numtries* open-run-close db:roll-up-pass-fail-counts #f run-id test-name item-path status))
(define (cdb:roll-up-pass-fail-counts serverdat run-id test-name item-path status)
  (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:roll-up-pass-fail-counts #f run-id test-name item-path status))

(define (cdb:get-test-info zmqsocket run-id test-name item-path)
  (cdb:client-call zmqsocket 'immediate #f *default-numtries* open-run-close db:get-test-info #f run-id test-name item-path))
(define (cdb:get-test-info serverdat run-id test-name item-path)
  (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:get-test-info #f run-id test-name item-path))

(define (cdb:get-test-info-by-id zmqsocket test-id)
  (cdb:client-call zmqsocket 'immediate #f *default-numtries* open-run-close db:get-test-info-by-id #f test-id))
(define (cdb:get-test-info-by-id serverdat test-id)
  (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:get-test-info-by-id #f test-id))

;; db should be db open proc or #f
(define (cdb:remote-run proc db . params)
  (apply cdb:client-call *runremote* 'immediate #f *default-numtries* open-run-close proc #f params))

(define (db:test-get-logfile-info db run-id test-name)
  (let ((res #f))
︙
This page was generated in about 0.121s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00