︙ | | |
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
|
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
|
-
+
|
;;======================================================================
;; Database access
;;======================================================================
(require-extension (srfi 18) extras tcp rpc)
(import (prefix rpc rpc:))
(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n zmq)
(import (prefix sqlite3 sqlite3:))
(declare (unit db))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
|
︙ | | |
51
52
53
54
55
56
57
58
59
60
61
62
63
64
|
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
|
+
|
#f))))
(if val
(begin
(debug:print-info 11 "db:set-sync, setting pragma synchronous to " val)
(sqlite3:execute db (conc "PRAGMA synchronous = '" val "';"))))))
(define (open-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
(if (not *toppath*)(setup-for-run))
(let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname)
(dbexists (file-exists? dbpath))
(db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath))
(handler (make-busy-timeout (if (args:get-arg "-override-timeout")
(string->number (args:get-arg "-override-timeout"))
136000)))) ;; 136000))) ;; 136000 = 2.2 minutes
(debug:print-info 11 "open-db, dbpath=" dbpath)
|
︙ | | |
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
|
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
|
-
+
-
-
+
+
+
+
+
+
|
(set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms)
(if throttle throttle 0.01)))
2))
(if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit
(begin
(debug:print-info 4 "launch throttle factor=" *global-delta*)
(set! *last-global-delta-printed* *global-delta*)))
(debug:print-info 11 "db:get-var END " var)
(debug:print-info 11 "db:get-var END " var " val=" res)
res))
(define (db:set-var db var val)
(debug:print-info 11 "db:set-var START " var " " val)
(sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)
(debug:print-info 11 "db:set-var END " var " " val)
)
(debug:print-info 11 "db:set-var END " var " " val))
(define (db:del-var db var)
(debug:print-info 11 "db:del-var START " var)
(sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var)
(debug:print-info 11 "db:del-var END " var))
;; use a global for some primitive caching, it is just silly to re-read the db
;; over and over again for the keys since they never change
(define (db:get-keys db)
(if *db-keys* *db-keys*
(let ((res '()))
|
︙ | | |
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
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
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
|
1076
1077
1078
1079
1080
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
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
|
-
-
-
-
+
-
+
-
+
+
-
+
+
+
+
+
-
-
+
+
+
+
-
+
-
+
-
-
-
-
-
-
+
-
-
-
-
+
-
-
-
-
-
-
+
|
t.logdat
t.run_duratio
t.comment
t.event_time
t.fail_count
t.pass_count
t.archived
FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE "
FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE "
keystr " AND r.runname LIKE '" runname "' AND item_path LIKE '" itempatt "' AND testname LIKE '"
testpatt "' AND t.state LIKE '" statepatt "' AND t.status LIKE '" statuspatt
"'ORDER BY t.event_time ASC;")))
(debug:print 3 "qrystr: " qrystr)
(sqlite3:for-each-row
(lambda (p)
(set! res (cons p res)))
db
qrystr)
res))
;;======================================================================
;; QUEUE UP META, TEST STATUS AND STEPS
;;======================================================================
;; db:updater is run in a thread to write out the cached data periodically
(define (db:updater)
(debug:print-info 4 "Starting cache processing")
(let loop ((start-time (current-time)))
(let loop ()
(thread-sleep! 10) ;; move save time around to minimize regular collisions?
(db:write-cached-data)
(loop start-time)))
(loop)))
;; cdb:cached-access is called by the server loop to dispatch commands or queue up
;; db accesses
;;
;; params := qry-name cached? val1 val2 val3 ...
(define (cdb:cached-access params)
(debug:print-info 12 "cdb:cached-access params=" params)
(if (< (length params) 2)
"ERROR"
(let ((qry-name (car params))
(cached? (cadr params))
(remparam (list-tail params 2)))
(debug:print-info 12 "cdb:cached-access qry-name=" qry-name " params=" params)
;; Any special calls are dispatched here.
;; Remainder are put in the db queue
(case qry-name
((login) ;; login checks that the megatest path matches
(if (null? remparam)
#f ;; no path - fail!
(let ((calling-path (car remparam)))
(if (equal? calling-path *toppath*)
#t ;; path matches - pass! Should vet the caller at this time ...
#f)))) ;; else fail to login
((flush)
(
(db:write-cached-data)
#t)
(else
(mutex-lock! *incoming-mutex*)
(set! *last-db-access* (current-seconds))
(set! *incoming-data* (cons
(vector qry-name
(current-milliseconds)
params)
*incoming-data*))
(mutex-unlock! *incoming-mutex*)
;; NOTE: if cached? is #f then this call must be run immediately
;; but first all calls in the queue are run first in the order
;; of their time stamp
(if (and cached? *cache-on*)
(begin
(debug:print-info 12 "*cache-on* is " *cache-on* ", skipping cache write")
"CACHED")
(begin
(db:write-cached-data)
"WRITTEN")))))))
(define (db:obj->string obj)(with-output-to-string (lambda ()(serialize obj))))
(define (db:string->obj msg)(with-input-from-string msg (lambda ()(deserialize))))
(define (cdb:client-call zmq-socket . params)
(debug:print-info 11 "zmq-socket " params)
(let ((zdat (with-output-to-string (lambda ()(serialize params))))
(debug:print-info 11 "cdb:client-call zmq-socket=" zmq-socket " params=" params)
(let ((zdat (db:obj->string params)) ;; (with-output-to-string (lambda ()(serialize params))))
(res #f))
(print "cdb:client-call before send message")
(send-message zmq-socket zdat)
(print "cdb:client-call after send message")
(set! res (receive-message zdat))
(set! res (db:string->obj (receive-message zmq-socket zdat)))
(debug:print-info 11 "zmq-socket " (car params) " res=" res)
res))
(define (cdb:test-set-status-state test-id status state msg)
(define (cdb:test-set-status-state zmqsocket test-id status state msg)
(debug:print-info 4 "cdb:test-set-status-state test-id=" test-id ", status=" status ", state=" state ", msg=" msg)
(mutex-lock! *incoming-mutex*)
(set! *last-db-access* (current-seconds))
(if msg
(set! *incoming-data* (cons (vector 'state-status-msg
(current-milliseconds)
(list state status msg test-id))
(cdb:client-call zmqsocket 'state-status-msg state status msg test-id)
*incoming-data*))
(set! *incoming-data* (cons (vector 'state-status
(current-milliseconds)
(list state status test-id)) ;; run-id test-name item-path minutes cpuload diskfree tmpfree)
(cdb:client-call zmqsocket 'state-status state status test-id))) ;; run-id test-name item-path minutes cpuload diskfree tmpfree)
*incoming-data*)))
(mutex-unlock! *incoming-mutex*)
(if *cache-on*
(debug:print-info 6 "*cache-on* is " *cache-on* ", skipping cache write")
(db:write-cached-data)))
(define (cdb:test-rollup-test_data-pass-fail zmqsocket test-id)
(cdb:client-call zmqsocket 'test_data-pf-rollup #t 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 fail-count pass-count test-id))
(define (cdb:tests-register-test zmqsocket db run-id test-name item-path)
|
︙ | | |
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
|
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
|
+
+
+
+
+
+
-
+
+
+
+
+
+
+
|
(set! *max-cache-size* cache-size)))
))
#f))
(define cdb:flush-queue db:write-cached-data)
(define (db:roll-up-pass-fail-counts db run-id test-name item-path status)
;; NEEDED!?
(rdb:flush-queue)
;; (rdb:flush-queue)
(if (and (not (equal? item-path ""))
(or (equal? status "PASS")
(equal? status "WARN")
(equal? status "FAIL")
(equal? status "WAIVED")
(equal? status "RUNNING")))
(begin
|
︙ | | |
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
|
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%")
;;======================================================================
;; REMOTE DB ACCESS VIA RPC
;;======================================================================
(define (rdb:open-run-close procname . remargs)
(if *runremote*
(let ((host (vector-ref *runremote* 0))
(port (vector-ref *runremote* 1)))
(apply (rpc:procedure 'rdb:open-run-close host port) procname remargs))
(apply open-run-close (eval procname) remargs)))
(define (rdb:test-set-status-state test-id status state msg)
(if *runremote*
(let ((host (vector-ref *runremote* 0))
(port (vector-ref *runremote* 1)))
(handle-exceptions
exn
(begin
(debug:print 0 "EXCEPTION: rpc call failed?")
(debug:print 0 " " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain)
(cdb:test-set-status-state test-id status state msg))
((rpc:procedure 'cdb:test-set-status-state host port) test-id status state msg)))
(cdb:test-set-status-state test-id status state msg)))
(define (rdb:test-rollup-test_data-pass-fail test-id)
(if *runremote*
(let ((host (vector-ref *runremote* 0))
(port (vector-ref *runremote* 1)))
((rpc:procedure 'cdb:test-rollup-test_data-pass-fail host port) test-id))
(cdb:test-rollup-test_data-pass-fail test-id)))
(define (rdb:pass-fail-counts test-id fail-count pass-count)
(if *runremote*
(let ((host (vector-ref *runremote* 0))
(port (vector-ref *runremote* 1)))
((rpc:procedure 'cdb:pass-fail-counts host port) test-id fail-count pass-count))
(cdb:pass-fail-counts test-id fail-count pass-count)))
;; currently forces a flush of the queue
(define (rdb:tests-register-test db run-id test-name item-path)
(if *runremote*
(let ((host (vector-ref *runremote* 0))
(port (vector-ref *runremote* 1)))
((rpc:procedure 'cdb:tests-register-test host port) db run-id test-name item-path force-write: #t))
(cdb:tests-register-test db run-id test-name item-path force-write: #t)))
(define (rdb:flush-queue)
(if *runremote*
(let ((host (vector-ref *runremote* 0))
(port (vector-ref *runremote* 1)))
((rpc:procedure 'cdb:flush-queue host port)))
(cdb:flush-queue)))
;; (define (rdb:test-set-status-state test-id status state msg)
;; (if *runremote*
;; (let ((host (vector-ref *runremote* 0))
;; (port (vector-ref *runremote* 1)))
;; (handle-exceptions
;; exn
;; (begin
;; (debug:print 0 "EXCEPTION: rpc call failed?")
;; (debug:print 0 " " ((condition-property-accessor 'exn 'message) exn))
;; (print-call-chain)
;; (cdb:test-set-status-state test-id status state msg))
;; ((rpc:procedure 'cdb:test-set-status-state host port) test-id status state msg)))
;; (cdb:test-set-status-state test-id status state msg)))
;;
;; (define (rdb:test-rollup-test_data-pass-fail test-id)
;; (if *runremote*
;; (let ((host (vector-ref *runremote* 0))
;; (port (vector-ref *runremote* 1)))
;; ((rpc:procedure 'cdb:test-rollup-test_data-pass-fail host port) test-id))
;; (cdb:test-rollup-test_data-pass-fail test-id)))
;;
;; (define (rdb:pass-fail-counts test-id fail-count pass-count)
;; (if *runremote*
;; (let ((host (vector-ref *runremote* 0))
;; (port (vector-ref *runremote* 1)))
;; ((rpc:procedure 'cdb:pass-fail-counts host port) test-id fail-count pass-count))
;; (cdb:pass-fail-counts test-id fail-count pass-count)))
;;
;; ;; currently forces a flush of the queue
;; (define (rdb:tests-register-test db run-id test-name item-path)
;; (if *runremote*
;; (let ((host (vector-ref *runremote* 0))
;; (port (vector-ref *runremote* 1)))
;; ((rpc:procedure 'cdb:tests-register-test host port) db run-id test-name item-path force-write: #t))
;; (cdb:tests-register-test db run-id test-name item-path force-write: #t)))
;;
;; (define (rdb:flush-queue)
;; (if *runremote*
;; (let ((host (vector-ref *runremote* 0))
;; (port (vector-ref *runremote* 1)))
;; ((rpc:procedure 'cdb:flush-queue host port)))
;; (cdb:flush-queue)))
;;
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
|
-
+
|
;; Copyright 2006-2012, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;; (include "common.scm")
;; (include "megatest-version.scm")
(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos) ;; (srfi 18) extras)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos zmq) ;; (srfi 18) extras)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
(declare (uses runs))
|
︙ | | |
250
251
252
253
254
255
256
257
258
259
260
261
262
263
|
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;; Misc general calls
;;======================================================================
(if (args:get-arg "-env2file")
(begin
(save-environment-as-files (args:get-arg "-env2file"))
(set! *didsomething* #t)))
;;======================================================================
;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
;; we start the server if not running else start the client thread
;;======================================================================
(if (args:get-arg "-server")
(let* ((toppath (setup-for-run))
(db (if toppath (open-db) #f)))
(debug:print-info 0 "Starting the standalone server")
(if db
(let* ((th2 (make-thread (lambda ()
(server:run (args:get-arg "-server")))))
(th3 (make-thread (lambda ()
(server:keep-running db)))))
(thread-start! th3)
(thread-start! th2)
(thread-join! th3)
(set! *didsomething* #t))
(debug:print 0 "ERROR: Failed to setup for megatest")))
;; not starting server? then start the client
(if (server:client-setup)
(debug:print-info 0 "connected as client")
(begin
(debug:print 0 "ERROR: Failed to connect as client")
(exit))))
;;======================================================================
;; Remove old run(s)
;;======================================================================
;; since several actions can be specified on the command line the removal
;; is done first
|
︙ | | |
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
|
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
+
+
+
+
-
+
+
+
|
(db:step-get-event_time step)))
steps)))))
tests))))
runs)
(set! *didsomething* #t)
)))
;;======================================================================
;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
;;======================================================================
(if (args:get-arg "-server")
(let* ((toppath (setup-for-run))
(db (if toppath (open-db) #f)))
(debug:print-info 0 "Starting the standalone server")
(if db
(let* ((host:port (db:get-var db "SERVER")) ;; this doen't support multiple servers BUG!!!!
(th2 (server:start db (args:get-arg "-server")))
(th3 (make-thread (lambda ()
(server:keep-running db host:port)))))
(thread-start! th3)
(thread-join! th3)
(set! *didsomething* #t))
(debug:print 0 "ERROR: Failed to setup for megatest"))))
;;======================================================================
;; full run
;;======================================================================
;; get lock in db for full run for this directory
;; for all tests with deps
;; walk tree of tests to find head tasks
;; add head tasks to task queue
;; add dependant tasks to task queue
;; add remaining tasks to task queue
;; for each task in task queue
;; if have adequate resources
;; launch task
;; else
;; put task in deferred queue
;; if still ok to run tasks
;; process deferred tasks per above steps
;; run all tests are are Not COMPLETED and PASS or CHECK
(if (args:get-arg "-runall")
(let ((server-thread #f))
(if (args:get-arg "-server")
(let ((toppath (setup-for-run))
(db (open-db)))
(if db
(let* ((host:port (db:get-var db "SERVER")) ;; this doen't support multiple servers BUG!!!!
(th2 (server:start db (args:get-arg "-server")))
(th3 (make-thread (lambda ()
(server:keep-running db host:port)))))
(thread-start! th3)
(set! server-thread th3)))))
(general-run-call
"-runall"
"run all tests"
(lambda (target runname keys keynames keyvallst)
(general-run-call
"-runall"
"run all tests"
(lambda (target runname keys keynames keyvallst)
(runs:run-tests target
runname
(if (args:get-arg "-testpatt")
(args:get-arg "-testpatt")
"%/%")
user
args:arg-hash)))) ;; )
args:arg-hash)))
(if server-thread
(thread-join! server-thread))))
;;======================================================================
;; run one test
;;======================================================================
;; 1. find the config file
;; 2. change to the test directory
|
︙ | | |
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
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
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
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
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
|
-
+
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
-
+
-
+
-
+
-
-
-
-
-
+
-
+
-
-
+
+
-
+
-
+
-
+
-
+
-
+
+
+
-
+
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;; Copyright 2006-2012, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
(require-extension (srfi 18) extras tcp rpc s11n)
(import (prefix rpc rpc:))
(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo zmq)
(import (prefix sqlite3 sqlite3:))
(declare (unit server))
(declare (uses common))
(declare (uses db))
(declare (uses tests))
(include "common_records.scm")
(include "db_records.scm")
(define a (with-output-to-string (lambda ()(serialize '(1 2 3 "Hello and goodbye" #t)))))
(define b (with-input-from-string a (lambda ()(deserialize))))
(define (server:run hostn)
(debug:print 0 "Attempting to start the server ...")
(let ((host:port (open-run-close db:get-var db "SERVER"))) ;; do whe already have a server running?
(let ((host:port (open-run-close db:get-var #f "SERVER"))) ;; do whe already have a server running?
(if host:port
(begin
(debug:print 0 "ERROR: server already running.")
(if (server:client-setup)
(begin
(debug:print-info 0 "Server is alive, exiting")
(exit))
(begin
(debug:print-info 0 "Server is dead, removing flag and trying again")
(open-run-close db:del-var #f "SERVER")
(set! *runremote* host:port)
(server:run hostn))))
(let* ((zmq-socket #f)
(hostname (if (string=? "-" hostn)
(get-host-name)
hostn))
(ipaddrstr (let ((ipstr (if (string=? "-" hostn)
(string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
#f)))
(if ipstr ipstr hostname))))
(set! zmq-socket (server:find-free-port-and-open ipaddrstr))
(set! zmq-socket (server:find-free-port-and-open ipaddrstr zmq-socket 5555))
(set! *cache-on* #t)
;; what to do when we quit
;;
(on-exit (lambda ()
(open-run-close
(open-run-close db:del-var #f "SERVER")
(lambda (db . params)
(sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER';"))
#f ;; for db
#f) ;; for a param
(let loop ()
(let ((queue-len 0))
(thread-sleep! (random 5))
(mutex-lock! *incoming-mutex*)
(set! queue-len (length *incoming-data*))
(mutex-unlock! *incoming-mutex*)
(if (> queue-len 0)
(begin
(debug:print-info 0 "Queue not flushed, waiting ...")
(loop)))))))
;; The heavy lifting
;;
(let loop ()
(let* ((rawmsg (receive-message zmq-socket))
(params (with-input-from-string rawmsg (lambda ()(deserialize))))
(params (db:string->obj rawmsg)) ;; (with-input-from-string rawmsg (lambda ()(deserialize))))
(res #f))
(debug:print-info 12 "server=> received msg=" msg)
(debug:print-info 12 "server=> received params=" params)
(set! res (cdb:cached-access params))
(debug:print-info 12 "server=> processed msg=" msg)
(send-message zmq-socket res)
(debug:print-info 12 "server=> processed res=" res)
(send-message zmq-socket (db:obj->string res))
(loop)))))))
;; run server:keep-running in a parallel thread to monitor that the db is being
;; used and to shutdown after sometime if it is not.
;;
(define (server:keep-running db host:port)
(define (server:keep-running db)
;; if none running or if > 20 seconds since
;; server last used then start shutdown
(let loop ((count 0))
(let loop ()
(thread-sleep! 20) ;; no need to do this very often
(let ((numrunning (db:get-count-tests-running db)))
(if (or (> numrunning 0)
(> (+ *last-db-access* 60)(current-seconds)))
(begin
(debug:print-info 0 "Server continuing, tests running: " numrunning ", seconds since last db access: " (- (current-seconds) *last-db-access*))
(loop (+ 1 count)))
(loop))
(begin
(debug:print-info 0 "Starting to shutdown the server side")
;; need to delete only *my* server entry (future use)
(sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER';")
(db:del-var db "SERVER")
(thread-sleep! 10)
(debug:print-info 0 "Max cached queries was " *max-cache-size*)
(debug:print-info 0 "Server shutdown complete. Exiting")
;; (exit)))
)))))
(define (server:find-free-port-and-open host s port)
(let ((s (if s s (make-socket 'rep)))
(p (if (number? port) port 5555)))
(handle-exceptions
exn
(begin
(print "Failed to bind to port " p ", trying next port")
(debug:print 0 "Failed to bind to port " p ", trying next port")
(debug:print 0 " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
(server:find-free-port-and-open host s (+ p 1)))
(let ((zmq-url (conc "tcp://" host ":" p)))
(print "Trying to start server on " zmq-url)
(bind-socket s zmq-url)
(set! *runremote* zmq-url)
(set! *runremote* #f)
(debug:print 0 "Server started on " zmq-url)
(db:set-var db "SERVER" zmq-url)
(open-run-close db:set-var #f "SERVER" zmq-url)
s))))
(define (server:client-setup)
(if *runremote*
(begin
(debug:print 0 "ERROR: Attempt to connect to server but already connected")
#f)
(let* ((hostinfo (open-run-close db:get-var #f "SERVER"))
(zmq-socket (make-socket 'req)))
(if hostinfo
(begin
(debug:print-info 2 "Setting up to connect to " hostinfo)
(handle-exceptions
exn
(begin
(debug:print 0 "ERROR: Failed to open a connection to the server at host: " host " port: " port)
(debug:print 0 " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
(set! *runremote* #f))
(if (and (connect-socket zmq-socket hostinfo)
(cdb:client-call zmq-socket 'login #t *toppath*))
(begin
(debug:print-info 2 "Logged in and connected to " host ":" port)
(set! *runremote* zmq-socket))
(begin
(debug:print-info 2 "Failed to login or connect to " host ":" port)
(set! *runremote* #f)))))
(debug:print-info 2 "no server available")))))
(let* ((hostinfo (open-run-close db:get-var #f "SERVER"))
(zmq-socket (make-socket 'req)))
(if hostinfo
(begin
(debug:print-info 2 "Setting up to connect to " hostinfo)
(handle-exceptions
exn
(begin
(debug:print 0 "ERROR: Failed to open a connection to the server at: " hostinfo)
(debug:print 0 " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
(debug:print 0 " perhaps jobs killed with -9? Removing server records")
(open-run-close db:del-var #f "SERVER")
(exit)
#f)
(let ((connect-ok #f))
(connect-socket zmq-socket hostinfo)
(set! connect-ok (cdb:client-call zmq-socket 'login #t *toppath*))
(if connect-ok
(begin
(debug:print-info 2 "Logged in and connected to " hostinfo)
(set! *runremote* zmq-socket)
#t)
(begin
(debug:print-info 2 "Failed to login or connect to " hostinfo)
(set! *runremote* #f)
#f)))))
(begin
(debug:print-info 2 "No server available, attempting to start one...")
(system (conc "megatest -server - " (if (args:get-arg "-debug")
(conc "-debug " (args:get-arg "-debug"))
"")
" &"))
(sleep 5)
(server:client-setup)))))
|