222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
|
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
|
+
+
+
+
+
-
+
+
+
+
+
-
+
|
(define (common:get-last-run-version-number)
(string->number
(substring (common:get-last-run-version) 0 6)))
(define (common:set-last-run-version)
(rmt:set-var "MEGATEST_VERSION" (common:version-signature)))
;; postive number if megatest version > db version
;; negative number if megatest version < db version
(define (common:version-db-delta)
(- megatest-version (common:get-last-run-version-number)))
(define (common:version-changed?)
(not (equal? (common:get-last-run-version)
(common:version-signature))))
(common:version-signature))))
(define (common:api-changed?)
(not (equal? (substring (->string megatest-version) 0 4)
(substring (common:get-last-run-version) 0 4))))
;; Move me elsewhere ...
;; RADT => Why do we meed the version check here, this is called only if version misma
;;
(define (common:cleanup-db dbstruct)
(db:multi-db-sync
dbstruct
'schema
;; 'new2old
'killservers
'dejunk
'adj-target
;; 'old2new
'new2old
)
(if (common:version-changed?)
(if (common:api-changed?)
(common:set-last-run-version)))
;; Rotate logs, logic:
;; if > 500k and older than 1 week:
;; remove previous compressed log and compress this log
;; WARNING: This proc operates assuming that it is in the directory above the
;; logs directory you wish to log-rotate.
|
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
|
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
|
-
-
-
-
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
((equal? status "WARN") "orange")
((equal? status "KILLED") "orange")
((equal? status "KILLREQ") "purple")
((equal? status "RUNNING") "blue")
((equal? status "ABORT") "brown")
(else "black")))
;;======================================================================
;; N A N O M S G C L I E N T
;;======================================================================
;; ;;======================================================================
;; ;; N A N O M S G C L I E N T
;; ;;======================================================================
;;
(define (server:get-best-guess-address hostname)
(let ((res #f))
(for-each
(lambda (adr)
(if (not (eq? (u8vector-ref adr 0) 127))
(set! res adr)))
;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME
(vector->list (hostinfo-addresses (hostname->hostinfo hostname))))
(string-intersperse
(map number->string
(u8vector->list
(if res res (hostname->ip hostname)))) ".")))
(define (common:send-dboard-main-changed)
(let* ((dashboard-ips (mddb:get-dashboards)))
(for-each
(lambda (ipadr)
(let* ((soc (common:open-nm-req (conc "tcp://" ipadr)))
(msg (conc "main " *toppath*))
(res (common:nm-send-receive-timeout soc msg)))
(if (not res) ;; couldn't reach that dashboard - remove it from db
(print "ERROR: couldn't reach dashboard " ipadr))
res))
dashboard-ips)))
;;======================================================================
;; D A S H B O A R D D B
;;======================================================================
(define (mddb:open-db)
(let* ((db (open-database (conc (get-environment-variable "HOME") "/.dashboard.db"))))
(set-busy-handler! db (busy-timeout 10000))
(for-each
(lambda (qry)
(exec (sql db qry)))
(list
"CREATE TABLE IF NOT EXISTS vars (id INTEGER PRIMARY KEY,key TEXT, val TEXT, CONSTRAINT varsconstraint UNIQUE (key));"
"CREATE TABLE IF NOT EXISTS dashboards (
id INTEGER PRIMARY KEY,
pid INTEGER,
username TEXT,
hostname TEXT,
ipaddr TEXT,
portnum INTEGER,
start_time TIMESTAMP DEFAULT (strftime('%s','now')),
CONSTRAINT hostport UNIQUE (hostname,portnum)
);"
))
db))
;; register a dashboard
;;
(define (mddb:register-dashboard port)
(let* ((pid (current-process-id))
(hostname (get-host-name))
(ipaddr (server:get-best-guess-address hostname))
(username (current-user-name)) ;; (car userinfo)))
(db (mddb:open-db)))
(print "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username)
(exec (sql db "INSERT OR REPLACE INTO dashboards (pid,username,hostname,ipaddr,portnum) VALUES (?,?,?,?,?);")
pid username hostname ipaddr port)
(close-database db)))
;; unregister a monitor
;;
(define (mddb:unregister-dashboard host port)
(let* ((db (mddb:open-db)))
(print "Register unregister monitor, host:port=" host ":" port)
(exec (sql db "DELETE FROM dashboards WHERE hostname=? AND portnum=?;") host port)
(close-database db)))
;; get registered dashboards
;;
(define (mddb:get-dashboards)
(let ((db (mddb:open-db)))
(query fetch-column
(sql db "SELECT ipaddr || ':' || portnum FROM dashboards;"))))
;;
;;
;; (define (common:send-dboard-main-changed)
;; (let* ((dashboard-ips (mddb:get-dashboards)))
;; (for-each
;; (lambda (ipadr)
;; (let* ((soc (common:open-nm-req (conc "tcp://" ipadr)))
;; (msg (conc "main " *toppath*))
;; (res (common:nm-send-receive-timeout soc msg)))
;; (if (not res) ;; couldn't reach that dashboard - remove it from db
;; (print "ERROR: couldn't reach dashboard " ipadr))
;; res))
;; dashboard-ips)))
;;
;;
;; ;;======================================================================
;; ;; D A S H B O A R D D B
;; ;;======================================================================
;;
;; (define (mddb:open-db)
;; (let* ((db (open-database (conc (get-environment-variable "HOME") "/.dashboard.db"))))
;; (set-busy-handler! db (busy-timeout 10000))
;; (for-each
;; (lambda (qry)
;; (exec (sql db qry)))
;; (list
;; "CREATE TABLE IF NOT EXISTS vars (id INTEGER PRIMARY KEY,key TEXT, val TEXT, CONSTRAINT varsconstraint UNIQUE (key));"
;; "CREATE TABLE IF NOT EXISTS dashboards (
;; id INTEGER PRIMARY KEY,
;; pid INTEGER,
;; username TEXT,
;; hostname TEXT,
;; ipaddr TEXT,
;; portnum INTEGER,
;; start_time TIMESTAMP DEFAULT (strftime('%s','now')),
;; CONSTRAINT hostport UNIQUE (hostname,portnum)
;; );"
;; ))
;; db))
;;
;; ;; register a dashboard
;; ;;
;; (define (mddb:register-dashboard port)
;; (let* ((pid (current-process-id))
;; (hostname (get-host-name))
;; (ipaddr (server:get-best-guess-address hostname))
;; (username (current-user-name)) ;; (car userinfo)))
;; (db (mddb:open-db)))
;; (print "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username)
;; (exec (sql db "INSERT OR REPLACE INTO dashboards (pid,username,hostname,ipaddr,portnum) VALUES (?,?,?,?,?);")
;; pid username hostname ipaddr port)
;; (close-database db)))
;;
;; ;; unregister a monitor
;; ;;
;; (define (mddb:unregister-dashboard host port)
;; (let* ((db (mddb:open-db)))
;; (print "Register unregister monitor, host:port=" host ":" port)
;; (exec (sql db "DELETE FROM dashboards WHERE hostname=? AND portnum=?;") host port)
;; (close-database db)))
;;
;; ;; get registered dashboards
;; ;;
;; (define (mddb:get-dashboards)
;; (let ((db (mddb:open-db)))
;; (query fetch-column
;; (sql db "SELECT ipaddr || ':' || portnum FROM dashboards;"))))
;;======================================================================
;; T E S T L A U N C H I N G P E R I T E M W I T H H O S T T Y P E S
;;======================================================================
;;
;; [hosts]
;; arm cubie01 cubie02
|
2302
2303
2304
2305
2306
2307
2308
2309
|
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(mthome-cfgfile (conc *toppath* "/.mtviews.config")))
(if (file-exists? mthome-cfgfile)
(read-config mthome-cfgfile view-cfgdat #t))
;; we load the home dir file AFTER the MTRAH file so the user can clobber settings when running the dashboard in read-only areas
(if (file-exists? home-cfgfile)
(read-config home-cfgfile view-cfgdat #t))
view-cfgdat))
;;======================================================================
;; Manage pkts, used in servers, tests and likely other contexts so put
;; in common
;;======================================================================
(define common:pkt-spec
'((server . ((action . a)
(pid . d)
(ipaddr . i)
(port . p)))
(test . ((cpuuse . c)
(diskuse . d)
(item-path . i)
(runname . r)
(state . s)
(target . t)
(status . u)))))
(define (common:get-pkts-dirs mtconf use-lt)
(let* ((pktsdirs-str (or (configf:lookup mtconf "setup" "pktsdirs")
(and use-lt
(conc *toppath* "/lt/.pkts"))))
(pktsdirs (if pktsdirs-str
(string-split pktsdirs-str " ")
#f)))
pktsdirs))
(define (common:with-queue-db mtconf proc #!key (use-lt #f)(toppath-in #f))
(let* ((pktsdirs (common:get-pkts-dirs mtconf use-lt))
(pktsdir (if pktsdirs (car pktsdirs) #f))
(toppath (or (configf:lookup mtconf "scratchdat" "toppath")
toppath-in))
(pdbpath (or (configf:lookup mtconf "setup" "pdbpath") pktsdir)))
(if (not (and pktsdir toppath pdbpath))
(begin
(print "ERROR: settings are missing in your megatest.config for area management.")
(print " you need to have pktsdir in the [setup] section."))
(let* ((pdb (open-queue-db pdbpath "pkts.db"
schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));"))))
(proc pktsdirs pktsdir pdb)
(dbi:close pdb)))))
(define (common:load-pkts-to-db mtconf)
(common:with-queue-db
mtconf
(lambda (pktsdirs pktsdir pdb)
(for-each
(lambda (pktsdir) ;; look at all
(if (and (file-exists? pktsdir)
(directory? pktsdir)
(file-read-access? pktsdir))
(let ((pkts (glob (conc pktsdir "/*.pkt"))))
(for-each
(lambda (pkt)
(let* ((uuid (cadr (string-match ".*/([0-9a-f]+).pkt" pkt)))
(exists (lookup-by-uuid pdb uuid #f)))
(if (not exists)
(let* ((pktdat (string-intersperse
(with-input-from-file pkt read-lines)
"\n"))
(apkt (pkt->alist pktdat))
(ptype (alist-ref 'T apkt)))
(add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0)
(debug:print 4 *default-log-port* "Added " uuid " of type " ptype " to queue"))
(debug:print 4 *default-log-port* "pkt: " uuid " exists, skipping...")
)))
pkts))))
pktsdirs))))
(define (common:get-pkt-alists pkts)
(map (lambda (x)
(alist-ref 'apkt x)) ;; 'pkta pulls out the alist from the read pkt
pkts))
;; given list of pkts (alist mode) return list of D cards as Unix epoch, sorted descending
;; also delete duplicates by target i.e. (car pkt)
;;
(define (common:get-pkt-times pkts)
(delete-duplicates
(sort
(map (lambda (x)
`(,(alist-ref 't x) . ,(string->number (alist-ref 'D x))))
pkts)
(lambda (a b)(> (cdr a)(cdr b)))) ;; sort descending
(lambda (a b)(equal? (car a)(car b))))) ;; remove duplicates by target
|