24
25
26
27
28
29
30
31
32
33
34
35
36
37
|
(use zmq)
(declare (unit db))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses fs-transport))
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")
;; timestamp type (val1 val2 ...)
|
>
|
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
|
(use zmq)
(declare (unit db))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses fs-transport))
(declare (uses client))
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")
;; timestamp type (val1 val2 ...)
|
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
|
;;======================================================================
;; Misc. test related queries
;;======================================================================
;; MUST BE CALLED local!
(define (db:test-get-paths-matching db keynames target fnamepatt #!key (res '()))
(let ((paths-from-db (cdb:remote-run db:test-get-paths-matching-keynames-target db keynames target res)))
(glob (conc p "/" fnamepatt)))
paths-from-db))
paths-from-db)))
(define (db:test-get-paths-matching-keynames-target db keynames target res)
(let* ((testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%"))
(statepatt (if (args:get-arg ":state") (args:get-arg ":state") "%"))
(statuspatt (if (args:get-arg ":status") (args:get-arg ":status") "%"))
(runname (if (args:get-arg ":runname") (args:get-arg ":runname") "%"))
(keystr (string-intersperse
(map (lambda (key val)
(conc "r." key " like '" val "'"))
keynames
(string-split target "/"))
" AND "))
(testqry (tests:match->sqlqry testpatt))
(qrystr (conc "SELECT t.rundir FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE "
|
>
>
>
>
>
|
>
>
>
>
>
|
>
|
>
|
|
|
|
|
|
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
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
|
;;======================================================================
;; Misc. test related queries
;;======================================================================
;; MUST BE CALLED local!
(define (db:test-get-paths-matching db keynames target fnamepatt #!key (res '()))
;; BUG: Move the values derived from args to parameters and push to megatest.scm
(let* ((testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%"))
(statepatt (if (args:get-arg ":state") (args:get-arg ":state") "%"))
(statuspatt (if (args:get-arg ":status") (args:get-arg ":status") "%"))
(runname (if (args:get-arg ":runname") (args:get-arg ":runname") "%"))
(paths-from-db (cdb:remote-run db:test-get-paths-matching-keynames-target db keynames target res
testpatt: testpatt
statepatt: statepatt
statuspatt: statuspatt
runname: runname)))
(if fnamepatt
(apply append
(map (lambda (p)
(if (directory-exists? p)
(glob (conc p "/" fnamepatt))
'()))
paths-from-db))
paths-from-db)))
(define (db:test-get-paths-matching-keynames-target db keynames target res
#!key
(testpatt "%")
(statepatt "%")
(statuspatt "%")
(runname "%"))
(let* ((keystr (string-intersperse
(map (lambda (key val)
(conc "r." key " like '" val "'"))
keynames
(string-split target "/"))
" AND "))
(testqry (tests:match->sqlqry testpatt))
(qrystr (conc "SELECT t.rundir FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE "
|
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
|
(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)
(case *transport-type*
((fs)
(let ((packet (vector "na" qtype immediate "na" params 0)))
(fs:process-queue-item packet)))
((http)
(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))))
(debug:print-info 11 "zdat=" zdat)
(let* ((res #f)
(rawdat (http-transport:client-send-receive serverdat zdat))
(tmp #f))
(debug:print-info 11 "Sent " zdat ", received " rawdat)
(set! tmp (db:string->obj rawdat))
(vector-ref tmp 2))))
((zmq)
(handle-exceptions
exn
(begin
(thread-sleep! 5)
(if (> numretries 0)(apply cdb:client-call serverdat qtype immediate (- numretries 1) params)))
(let* ((push-socket (vector-ref serverdat 0))
(sub-socket (vector-ref serverdat 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 ()
;; 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))))
(if (equal? query-sig (vector-ref myres 1))
(set! res (vector-ref myres 2))
(loop))))))
|
|
|
|
|
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
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
|
(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)
(case *transport-type*
((fs)
(let ((packet (vector "na" qtype immediate "na" params 0)))
(fs:process-queue-item packet)))
((http)
(let* ((client-sig (client:get-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))))
(debug:print-info 11 "zdat=" zdat)
(let* ((res #f)
(rawdat (http-transport:client-send-receive serverdat zdat))
(tmp #f))
(debug:print-info 11 "Sent " zdat ", received " rawdat)
(set! tmp (db:string->obj rawdat))
(vector-ref tmp 2))))
((zmq)
(handle-exceptions
exn
(begin
(thread-sleep! 5)
(if (> numretries 0)(apply cdb:client-call serverdat qtype immediate (- numretries 1) params)))
(let* ((push-socket (vector-ref serverdat 0))
(sub-socket (vector-ref serverdat 1))
(client-sig (client:get-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 ()
;; get the sender info
;; this should match (client:get-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))))
(if (equal? query-sig (vector-ref myres 1))
(set! res (vector-ref myres 2))
(loop))))))
|