1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
|
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
|
-
-
+
+
-
+
|
(zdat (db:obj->string (vector client-sig qtype immediate query-sig params (current-seconds)))) ;; (with-output-to-string (lambda ()(serialize params))))
)
;; (print "zdat=" zdat)
(let* (
(res #f)
(rawdat (server:client-send-receive serverdat zdat))
(tmp #f))
(print "Sent " zdat ", received " rawdat)
(set! tmp (db:string->obj newres))
(debug:print-info 11 "Sent " zdat ", received " rawdat)
(set! tmp (db:string->obj rawdat))
;; (if (equal? query-sig (vector-ref myres 1))
;; (set! res
(vector-ref myres 2)
(vector-ref tmp 2)
;; (loop (server:client-send-receive serverdat zdat)))))))
;; (timeout (lambda ()
;; (let loop ((n numretries))
;; (thread-sleep! 15)
;; (if (not res)
;; (if (> numretries 0)
;; (begin
|
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
|
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
|
-
+
-
+
-
+
-
-
+
+
-
+
-
+
-
+
-
+
|
(let* ((data (sort indata (lambda (a b)
(< (cdb:packet-get-qtime a)(cdb:packet-get-qtime b))))))
(for-each
(lambda (item)
(db:process-queue-item db pubsock item))
data)))
(define (db:process-queue-item db pubsock item)
(define (db:process-queue-item db item)
(let* ((stmt-key (cdb:packet-get-qtype item))
(qry-sig (cdb:packet-get-query-sig item))
(return-address (cdb:packet-get-client-sig item))
(params (cdb:packet-get-params item))
(query (let ((q (alist-ref stmt-key db:queries)))
(if q (car q) #f))))
(debug:print-info 11 "Special queries/requests stmt-key=" stmt-key ", return-address=" return-address ", qrery=" query ", params=" params)
(cond
(query
(apply sqlite3:execute db query params)
(server:reply pubsock return-address qry-sig #t #t))
((member stmt-key db:special-queries)
(debug:print-info 11 "Handling special statement " stmt-key)
(case stmt-key
((immediate)
(let ((proc (car params))
(remparams (cdr params)))
;; we are being handed a procedure so call it
(debug:print-info 11 "Running (apply " proc " " remparams ")")
(server:reply pubsock return-address qry-sig #t (apply proc remparams))))
(server:reply return-address qry-sig #t (apply proc remparams))))
((login)
(if (< (length params) 3) ;; should get toppath, version and signature
'(#f "login failed due to missing params") ;; missing params
(server:reply return-address qry-sig '(#f "login failed due to missing params")) ;; missing params
(let ((calling-path (car params))
(calling-vers (cadr params))
(client-key (caddr params)))
(if (and (equal? calling-path *toppath*)
(equal? megatest-version calling-vers))
(begin
(hash-table-set! *logged-in-clients* client-key (current-seconds))
(server:reply pubsock return-address qry-sig #t '(#t "successful login"))) ;; path matches - pass! Should vet the caller at this time ...
(list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*))))))
(server:reply return-address qry-sig #t '(#t "successful login"))) ;; path matches - pass! Should vet the caller at this time ...
(server:reply return-address qry-sig #f (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*)))))))
((flush sync)
(server:reply pubsock return-address qry-sig #t 1)) ;; (length data)))
(server:reply return-address qry-sig #t 1)) ;; (length data)))
((set-verbosity)
(set! *verbosity* (car params))
(server:reply pubsock return-address qry-sig #t '(#t *verbosity*)))
(server:reply return-address qry-sig #t '(#t *verbosity*)))
((killserver)
(debug:print 0 "WARNING: Server going down in 15 seconds by user request!")
(open-run-close tasks:server-deregister tasks:open-db
(cadr *server-info*)
pullport: (caddr *server-info*))
(thread-start! (make-thread (lambda ()(thread-sleep! 15)(exit))))
(server:reply pubsock return-address qry-sig #t '(#t "exit process started")))
(server:reply return-address qry-sig #t '(#t "exit process started")))
(else ;; not a command, i.e. is a query
(debug:print 0 "ERROR: Unrecognised query/command " stmt-key)
(server:reply pubsock return-address qry-sig #f 'failed))))
(else
(debug:print-info 11 "Executing " stmt-key " for " params)
(apply sqlite3:execute (hash-table-ref queries stmt-key) params)
(server:reply pubsock return-address qry-sig #t #t)))))
(server:reply return-address qry-sig #t #t)))))
(define (db:test-get-records-for-index-file db run-id test-name)
(let ((res '()))
(sqlite3:for-each-row
(lambda (id itempath state status run_duration logf comment)
(set! res (cons (vector id itempath state status run_duration logf comment) res)))
db
|