15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
(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)
|
<
<
|
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:))
(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
|
(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))
;; 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)
|
|
|
|
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 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
|
(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-by-test-id zmqsocket test-id rundir)
(cdb:client-call zmqsocket '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)))
;;======================================================================
;; 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") "%"))
|
|
|
|
|
|
|
|
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! 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 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! 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
|
(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)
(handle-exceptions
exn
(begin
(thread-sleep! 5)
(if (> numretries 0)(apply cdb:client-call zmq-sockets 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))
(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 ()
(receive-message* sub-socket)
(let ((myres (db:string->obj (receive-message* sub-socket))))
(if (equal? query-sig (vector-ref myres 1))
(set! res (vector-ref myres 2))
(loop))))))
(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))
(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:login zmq-sockets keyval signature)
(cdb:client-call zmq-sockets '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:num-clients zmq-socket)
(cdb:client-call zmq-socket 'numclients #t *default-numtries*))
(define (cdb:test-set-status-state zmqsocket 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)
(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: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:tests-register-test zmqsocket 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)))
(define (cdb:flush-queue zmqsocket)
(cdb:client-call zmqsocket 'flush #f *default-numtries*))
(define (cdb:kill-server zmqsocket)
(cdb:client-call zmqsocket '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: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-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))
;; 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))
|
|
|
|
<
<
|
<
<
<
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
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 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 serverdat qtype immediate (- numretries 1) params)))
(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 ()
(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
;; now get the actual message
(let ((myres (db:string->obj res)))
(if (equal? query-sig (vector-ref myres 1))
(set! res (vector-ref myres 2))
(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 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 serverdat val)
(cdb:client-call serverdat 'set-verbosity #f *default-numtries* val))
(define (cdb:login serverdat keyval signature)
(cdb:client-call serverdat 'login #t *default-numtries* keyval megatest-version signature))
(define (cdb:logout serverdat keyval signature)
(cdb:client-call serverdat 'logout #t *default-numtries* keyval signature))
(define (cdb:num-clients serverdat)
(cdb:client-call serverdat 'numclients #t *default-numtries*))
(define (cdb:test-set-status-state serverdat test-id status state msg)
(if msg
(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 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 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 serverdat run-id test-name item-path)
(let ((item-paths (if (equal? item-path "")
(list item-path)
(list item-path ""))))
(cdb:client-call serverdat 'register-test #t *default-numtries* run-id test-name item-path)))
(define (cdb:flush-queue serverdat)
(cdb:client-call serverdat 'flush #f *default-numtries*))
(define (cdb:kill-server serverdat)
(cdb:client-call serverdat 'killserver #f *default-numtries*))
(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 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 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))
|