Overview
Context
Changes
Modified client.scm
from [51872c6c8c]
to [a5253ced0b].
︙ | | |
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
|
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
|
-
+
-
+
-
-
-
-
-
+
+
+
+
-
+
|
(http-transport:close-connections run-id)
(hash-table-delete! *runremote* run-id)
(if (< remaining-tries 8)
(thread-sleep! 5)
(thread-sleep! 1))
(client:setup run-id remaining-tries: (- remaining-tries 1)))))
;; YUK: rename server-dat here
(let* ((server-dat (open-run-close tasks:get-server tasks:open-db run-id)))
(let* ((server-dat (tasks:get-server (tasks:get-db) run-id)))
(debug:print-info 4 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
(if server-dat
(let* ((iface (tasks:hostinfo-get-interface server-dat))
(port (tasks:hostinfo-get-port server-dat))
(start-res (http-transport:client-connect iface port))
(ping-res (rmt:login-no-auto-client-setup start-res run-id)))
(if (and start-res
ping-res)
(begin
(hash-table-set! *runremote* run-id start-res)
(debug:print-info 2 "connected to " (http-transport:server-dat-make-url start-res))
start-res)
(begin ;; login failed but have a server record, clean out the record and try again
(debug:print-info 0 "client:setup, login failed, will attempt to start server ... start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat)
(http-transport:close-connections run-id)
(hash-table-delete! *runremote* run-id)
(open-run-close tasks:server-force-clean-run-record
(tasks:server-force-clean-run-record (tasks:get-db)
tasks:open-db
run-id
(tasks:hostinfo-get-interface server-dat)
(tasks:hostinfo-get-port server-dat)
" client:setup (server-dat = #t)")
run-id
(tasks:hostinfo-get-interface server-dat)
(tasks:hostinfo-get-port server-dat)
" client:setup (server-dat = #t)")
(thread-sleep! 2)
(server:try-running run-id)
(thread-sleep! 10) ;; give server a little time to start up
(client:setup run-id remaining-tries: (- remaining-tries 1)))))
(begin ;; no server registered
(let ((num-available (open-run-close tasks:num-in-available-state tasks:open-db run-id)))
(let ((num-available (tasks:num-in-available-state (tasks:get-db) run-id)))
(debug:print-info 0 "client:setup, no server registered, remaining-tries=" remaining-tries " num-available=" num-available)
(thread-sleep! 2)
(if (< num-available 2)
(begin
;; (open-run-close tasks:server-clean-out-old-records-for-run-id tasks:open-db run-id " client:setup (server-dat=#f)")
(server:try-running run-id)))
(thread-sleep! 10) ;; give server a little time to start up
|
︙ | | |
Modified common.scm
from [090cb13503]
to [3a0b3ba970].
︙ | | |
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
|
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
|
-
+
+
+
+
+
+
-
-
-
-
|
(define *already-seen-runconfig-info* #f)
(define *waiting-queue* (make-hash-table))
(define *test-meta-updated* (make-hash-table))
(define *globalexitstatus* 0) ;; attempt to work around possible thread issues
(define *passnum* 0) ;; when running track calls to run-tests or similar
(define *write-frequency* (make-hash-table)) ;; run-id => (vector (current-seconds) 0))
(define *alt-log-file* #f) ;; used by -log
(define *db-sync-mutex* (make-mutex))
;; DATABASE
(define *dbstruct-db* #f)
(define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total >
(define *db-stats-mutex* (make-mutex))
(define *db-sync-mutex* (make-mutex))
(define *megatest-db* #f)
(define *last-db-access* (current-seconds)) ;; update when db is accessed via server
(define *db-write-access* #t)
(define *inmemdb* #f)
(define *task-db* #f) ;; (vector db path-to-db)
;; SERVER
(define *my-client-signature* #f)
(define *transport-type* 'http)
(define *megatest-db* #f)
(define *rpc:listener* #f) ;; if set up for server communication this will hold the tcp port
(define *runremote* (make-hash-table)) ;; if set up for server communication this will hold <host port>
(define *last-db-access* (current-seconds)) ;; update when db is accessed via server
(define *max-cache-size* 0)
(define *logged-in-clients* (make-hash-table))
(define *client-non-blocking-mode* #f)
(define *server-id* #f)
(define *server-info* #f)
(define *time-to-exit* #f)
(define *received-response* #f)
(define *default-numtries* 10)
(define *server-run* #t)
(define *db-write-access* #t)
(define *inmemdb* #f)
(define *run-id* #f)
(define *server-kind-run* (make-hash-table))
(define *target* (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN
(define *keys* (make-hash-table)) ;; cache the keys here
(define *keyvals* (make-hash-table))
(define *toptest-paths* (make-hash-table)) ;; cache toptest path settings here
|
︙ | | |
Modified dcommon.scm
from [e745585d38]
to [fce5cd6e64].
︙ | | |
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
|
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
|
-
+
|
(servers-matrix (iup:matrix #:expand "YES"
#:numcol 7
#:numcol-visible 7
#:numlin-visible 5
))
(colnames (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "RunTime" "State" "RunId"))
(updater (lambda ()
(let ((servers (open-run-close tasks:get-all-servers tasks:open-db)))
(let ((servers (tasks:get-all-servers (tasks:get-db))))
(iup:attribute-set! servers-matrix "NUMLIN" (length servers))
;; (set! colnum 0)
;; (for-each (lambda (colname)
;; ;; (print "colnum: " colnum " colname: " colname)
;; (iup:attribute-set! servers-matrix (conc "0:" colnum) colname)
;; (set! colnum (+ 1 colnum)))
;; colnames)
|
︙ | | |
Modified http-transport.scm
from [962c24d755]
to [c90a1ae0c7].
︙ | | |
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
|
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
|
-
+
-
-
+
+
-
+
|
;; get_next_port goes here
(http-transport:try-start-server run-id
ipaddrstr
(portlogger:open-run-close portlogger:find-port)
server-id))
(begin
(open-run-close tasks:server-force-clean-run-record tasks:open-db run-id ipaddrstr portnum " http-transport:try-start-server")
(tasks:server-force-clean-run-record (tasks:get-db) run-id ipaddrstr portnum " http-transport:try-start-server")
(print "ERROR: Tried and tried but could not start the server"))))
;; any error in following steps will result in a retry
(set! *server-info* (list ipaddrstr portnum))
(open-run-close tasks:server-set-interface-port
tasks:open-db
(tasks:server-set-interface-port
(tasks:get-db)
server-id
ipaddrstr portnum)
(debug:print 0 "INFO: Trying to start server on " ipaddrstr ":" portnum)
;; This starts the spiffy server
;; NEED WAY TO SET IP TO #f TO BIND ALL
;; (start-server bind-address: ipaddrstr port: portnum)
(if config-hostname ;; this is a hint to bind directly
(start-server port: portnum bind-address: (if (equal? config-hostname "-")
ipaddrstr
config-hostname))
(start-server port: portnum))
;; (portlogger:open-run-close portlogger:set-port portnum "released")
(open-run-close tasks:server-force-clean-run-record tasks:open-db run-id ipaddrstr portnum " http-transport:try-start-server")
(tasks:server-force-clean-run-record (tasks:get-db) run-id ipaddrstr portnum " http-transport:try-start-server")
(debug:print 1 "INFO: server has been stopped"))))
;;======================================================================
;; S E R V E R U T I L I T I E S
;;======================================================================
;;======================================================================
|
︙ | | |
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
|
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
|
-
+
-
+
-
+
|
(begin
(current-error-port *alt-log-file*)
(current-output-port *alt-log-file*)))))
(if (server:check-if-running run-id)
(begin
(debug:print 0 "INFO: Server for run-id " run-id " already running")
(exit 0)))
(let loop ((server-id (open-run-close tasks:server-lock-slot tasks:open-db run-id))
(let loop ((server-id (tasks:server-lock-slot (tasks:get-db) run-id))
(remtries 4))
(if (not server-id)
(if (> remtries 0)
(begin
(thread-sleep! 2)
(loop (open-run-close tasks:server-lock-slot tasks:open-db run-id)
(loop (tasks:server-lock-slot (tasks:get-db) run-id)
(- remtries 1)))
(begin
;; since we didn't get the server lock we are going to clean up and bail out
(debug:print-info 2 "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
(open-run-close tasks:server-delete-records-for-this-pid tasks:open-db " http-transport:launch")
(tasks:server-delete-records-for-this-pid tasks:get-db " http-transport:launch")
))
(let* ((th2 (make-thread (lambda ()
(debug:print-info 0 "Server run thread started")
(http-transport:run
(if (args:get-arg "-server")
(args:get-arg "-server")
"-")
|
︙ | | |
Modified megatest.scm
from [846662f97b]
to [f929956576].
︙ | | |
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
|
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
|
-
+
+
|
(debug:print 0 "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval)
(hash-table-set! args:arg-hash "-testpatt" newval)
(hash-table-delete! args:arg-hash "-itempatt")))
(on-exit (lambda ()
(rmt:print-db-stats)
(if *dbstruct-db* (db:close-all *dbstruct-db*))
(if *megatest-db* (sqlite3:finalize! *megatest-db*))))
(if *megatest-db* (sqlite3:finalize! *megatest-db*))
(if *task-db* (sqlite3:finalize! (vector-ref *task-db* 0)))))
;;======================================================================
;; Misc general calls
;;======================================================================
(if (args:get-arg "-env2file")
(begin
|
︙ | | |
Modified rmt.scm
from [cc9e85b1fb]
to [20d57b8c3b].
︙ | | |
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
|
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
|
-
+
|
(define (rmt:send-receive cmd rid params)
(let* ((run-id (if rid rid 0))
(connection-info (let ((cinfo (hash-table-ref/default *runremote* run-id #f)))
(if cinfo
cinfo
;; NB// can cache the answer for server running for 10 seconds ...
;; ;; (and (not (rmt:write-frequency-over-limit? cmd run-id))
(if (open-run-close tasks:server-running-or-starting? tasks:open-db run-id)
(if (tasks:server-running-or-starting? (tasks:get-db) run-id)
(let ((res (client:setup run-id)))
(if res
(hash-table-ref/default *runremote* run-id #f) ;; client:setup filled this in (hopefully)
#f))
#f))))
(jparams (db:obj->string params)))
(if connection-info
|
︙ | | |
Modified server.scm
from [e660b98e2f]
to [2e4c938473].
︙ | | |
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
|
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
|
-
+
|
(cmdln (conc (common:get-megatest-exe)
" -server " (or target-host "-") " -run-id " run-id (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
(conc " -daemonize -log " logfile)
"")
" -debug 4 "))) ;; (conc " >> " logfile " 2>&1 &")))))
(debug:print 0 "INFO: Starting server (" cmdln ") as none running ...")
(push-directory *toppath*)
(if (not (directory-exists? "logs"))(create-directory "logs"))
(if (not (directory-exists? "logs"))(create-directory "logs"))l
;; host.domain.tld match host?
(if (and target-host
;; look at target host, is it host.domain.tld or ip address and does it
;; match current ip or hostname
(not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host))
(not (equal? curr-ip target-host)))
(begin
|
︙ | | |
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
156
157
158
159
160
161
162
163
164
165
|
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
156
157
158
159
160
161
162
163
164
165
|
-
+
-
+
-
+
|
;;
(define (server:try-running run-id)
(if (eq? run-id 0)
(server:run run-id)
(rmt:start-server run-id)))
(define (server:check-if-running run-id)
(let loop ((server (open-run-close tasks:get-server tasks:open-db run-id))
(let loop ((server (tasks:get-server (tasks:get-db) run-id))
(trycount 0))
(if server
;; note: client:start will set *runremote*. this needs to be changed
;; also, client:start will login to the server, also need to change that.
;;
;; client:start returns #t if login was successful.
;;
(let ((res (server:ping-server run-id
(tasks:hostinfo-get-interface server)
(tasks:hostinfo-get-port server))))
;; if the server didn't respond we must remove the record
(if res
#t
(begin
(debug:print-info 0 "server at " server " not responding, removing record")
(open-run-close tasks:server-force-clean-running-records-for-run-id tasks:open-db run-id
(tasks:server-force-clean-running-records-for-run-id (tasks:get-db) run-id
" server:check-if-running")
res)))
#f)))
;; called in megatest.scm, host-port is string hostname:port
;;
(define (server:ping run-id host:port)
(let* ((host-port (let ((slst (string-split host:port ":")))
(if (eq? (length slst) 2)
(list (car slst)(string->number (cadr slst)))
#f)))
(toppath (launch:setup-for-run))
(server-db-dat (if (not host-port)(open-run-close tasks:get-server tasks:open-db run-id) #f)))
(server-db-dat (if (not host-port)(tasks:get-server (tasks:get-db) run-id) #f)))
(if (not run-id)
(begin
(debug:print 0 "ERROR: must specify run-id when doing ping, -run-id n")
(print "ERROR: No run-id")
(exit 1))
(if (and (not host-port)
(not server-db-dat))
|
︙ | | |
Modified tasks.scm
from [a6ce176766]
to [29d82aadd7].
︙ | | |
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
|
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
|
+
+
+
+
+
+
+
-
-
+
|
(thread-sleep! 1)
(loop (file-exists? fullpath)
(- count 1)))
(begin
(if remove (system (conc "rm -rf " path)))
#f))
#t))))
(define (tasks:get-task-db-path)
(if *task-db*
(vector-ref *task-db* 1)
(let* ((linktree (configf:lookup *configdat* "setup" "linktree"))
(dbpath (conc linktree "/.db/monitor.db")))
dbpath)))
;; If file exists AND
;; file readable
;; ==> open it
;; If file exists AND
;; file NOT readable
;; ==> open in-mem version
;; If file NOT exists
;; ==> open in-mem version
;;
(define (tasks:open-db)
(let* ((linktree (configf:lookup *configdat* "setup" "linktree"))
(dbpath (conc linktree "/.db/monitor.db"))
(let* ((dbpath (tasks:get-task-db-path))
(avail (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away
(exists (file-exists? dbpath))
(write-access (file-write-access? dbpath))
(mdb (cond
((file-write-access? *toppath*)(sqlite3:open-database dbpath))
((file-read-access? dbpath) (sqlite3:open-database dbpath))
(else (sqlite3:open-database ":memory:")))) ;; (never-give-up-open-db dbpath))
|
︙ | | |
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
|
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
|
-
+
+
+
+
+
+
+
+
+
|
cmdline TEXT,
login_time TIMESTAMP,
logout_time TIMESTAMP DEFAULT -1,
CONSTRAINT clients_constraint UNIQUE (pid,hostname));")
))
mdb))
(define (tasks:get-db)
(if *task-db*
*task-db*
(let ((db (tasks:open-db))
(pth (tasks:get-task-db-path)))
(set! *task-db* (vector db pth))
db)))
;;======================================================================
;; Server and client management
;;======================================================================
;; make-vector-record tasks hostinfo id interface port pubport transport pid hostname
(define (tasks:hostinfo-get-id vec) (vector-ref vec 0))
(define (tasks:hostinfo-get-interface vec) (vector-ref vec 1))
|
︙ | | |
tests/installall/config/megatest.config.dat became
a regular file with contents
[736a5da885].
tests/installall/config/runconfigs.config.dat became
a regular file with contents
[3b8f260acb].