| ︙ | | | ︙ | |
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
|
;; (include "common.scm")
;; (include "megatest-version.scm")
;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
(use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
srfi-18 extras format pkts regex regex-case
(prefix dbi dbi:)
nanomsg)
(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
(declare (uses configf))
;; (declare (uses rmt))
(include "megatest-fossil-hash.scm")
(require-library stml)
;; stuff for the mapper and checker functions
;;
(define *target-mappers* (make-hash-table))
(define *runname-mappers* (make-hash-table))
(define *area-checkers* (make-hash-table))
;; helpers for mappers/checkers
(define (add-target-mapper name proc)
(hash-table-set! *target-mappers* name proc))
(define (add-runname-mapper name proc)
(hash-table-set! *runname-mappers* name proc))
(define (add-area-checker name proc)
|
|
>
>
>
>
>
>
>
>
>
|
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
|
;; (include "common.scm")
;; (include "megatest-version.scm")
;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
(use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
srfi-19 srfi-18 extras format pkts regex regex-case
(prefix dbi dbi:)
nanomsg)
(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
(declare (uses configf))
;; (declare (uses rmt))
(use ducttape-lib)
(include "megatest-fossil-hash.scm")
(require-library stml)
;; stuff for the mapper and checker functions
;;
(define *target-mappers* (make-hash-table))
(define *runname-mappers* (make-hash-table))
(define *area-checkers* (make-hash-table))
(define (mtut:stml->string in-stml)
(with-output-to-string
(lambda ()
(s:output-new
(current-output-port)
in-stml))))
;; helpers for mappers/checkers
(define (add-target-mapper name proc)
(hash-table-set! *target-mappers* name proc))
(define (add-runname-mapper name proc)
(hash-table-set! *runname-mappers* name proc))
(define (add-area-checker name proc)
|
| ︙ | | | ︙ | |
212
213
214
215
216
217
218
219
220
221
222
223
224
225
|
("-load" . #f) ;; load and exectute a scheme file
("-log" . #f)
("-override-user" . #f)
("-msg" . M)
("-start-dir" . S)
("-set-vars" . v)
("-config" . h)
))
(define *switch-keys*
'(
("-h" . #f)
("-help" . #f)
("--help" . #f)
("-manual" . #f)
|
>
|
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
|
("-load" . #f) ;; load and exectute a scheme file
("-log" . #f)
("-override-user" . #f)
("-msg" . M)
("-start-dir" . S)
("-set-vars" . v)
("-config" . h)
("-time-out" . t)
))
(define *switch-keys*
'(
("-h" . #f)
("-help" . #f)
("--help" . #f)
("-manual" . #f)
|
| ︙ | | | ︙ | |
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
|
exn
(let ((emsg ((condition-property-accessor 'exn 'message) exn)))
(print "ERROR: Failed to start server \"" emsg "\"")
(exit 1))
(nn-bind rep (conc "tcp://*:" portnum)))
rep))
;; open connection to server, send message, close connection
;;
(define (open-send-close-nn host-port msg #!key (timeout 3)) ;; default timeout is 3 seconds
(let ((req (nn-socket 'req))
(uri (conc "tcp://" host-port))
(res #f))
(handle-exceptions
exn
(let ((emsg ((condition-property-accessor 'exn 'message) exn)))
(print "ERROR: Failed to connect/send to " uri " message was \"" emsg "\"")
#f)
(nn-connect req uri)
(nn-send req msg)
;; NEED timer here!
|
>
>
>
>
>
>
>
>
>
>
>
>
|
|
>
>
>
|
>
>
>
>
>
>
>
>
<
>
|
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
|
exn
(let ((emsg ((condition-property-accessor 'exn 'message) exn)))
(print "ERROR: Failed to start server \"" emsg "\"")
(exit 1))
(nn-bind rep (conc "tcp://*:" portnum)))
rep))
(define (can-user-kill-listner user-info attrib)
(let* ((contacts (alist-ref 'contact attrib))
(user-id (cadddr (cdr user-info)))
(ret #f)
(contact-list (string-split contacts ",")))
(for-each
(lambda (admin)
(if (string-contains user-id (car (string-split admin "@")))
(set! ret #t)))
contact-list)
ret))
;; open connection to server, send message, close connection
;;
(define (open-send-close-nn host-port msg attrib #!key (timeout 3) ) ;; default timeout is 3 seconds
(let ((req (nn-socket 'req))
(uri (conc "tcp://" host-port))
(res #f)
(contacts (alist-ref 'contact attrib))
(mode (alist-ref 'mode attrib)))
(handle-exceptions
exn
(let ((emsg ((condition-property-accessor 'exn 'message) exn)))
;; Send notification
(print "ERROR: Failed to connect / send to " uri " message was \"" emsg "\"" )
(if (equal? mode "production")
(begin
(print " Sending email to contacts : " contacts )
(let ((email-body (mtut:stml->string (s:body
(s:p (conc "We could not send messages to the server on " uri "." "Please check if the listner is running. It is possible that the host is overloaded due to which it may take too long to respond. \n Contact your system adminstrator if server load is high." (s:br)" Thank You ") )))))
(sendmail (string-join (string-split contacts ";" )) (conc "[Listner Error] Filed to connect to listner on " uri) email-body use_html: #t)))
(print " mode : " mode " Not sending any emails" ))
#f)
(nn-connect req uri)
(print "Connected to the server " )
(nn-send req msg)
(print "Request Sent")
(let* ((th1 (make-thread (lambda ()
(let ((resp (nn-recv req)))
(nn-close req)
(set! res (if (equal? resp "ok")
#t
#f))))
"recv thread"))
|
| ︙ | | | ︙ | |
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
|
(cond
((and access-types (member action allowed-actions))
;; (print "Access granted for " user " for " action)
#t)
(else
;; (print "Access denied for " user " for " action)
#f))))))
(define (get-pkts-dir mtconf)
(let ((pktsdirs (configf:lookup mtconf "setup" "pktsdirs"))
(pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f)))
pktsdir))
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.mtutilrc")))
(if (common:file-exists? debugcontrolf)
(load debugcontrolf)))
(if *action*
(case (string->symbol *action*)
((run remove rerun rerun-clean rerun-all set-ss archive kill list)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(area (args:get-arg "-area")) ;; look up the area to dispatch to from [areas] section
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
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
1271
1272
1273
|
(cond
((and access-types (member action allowed-actions))
;; (print "Access granted for " user " for " action)
#t)
(else
;; (print "Access denied for " user " for " action)
#f))))))
(define (open-logfile logpath)
(condition-case
(let* ((log-dir (or (pathname-directory logpath) ".")))
(if (not (directory-exists? log-dir))
(system (conc "mkdir -p " log-dir)))
(open-output-file logpath))
(exn ()
(debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath)
(define *didsomething* #t)
(exit 1))))
(define (get-pkts-dir mtconf)
(let ((pktsdirs (configf:lookup mtconf "setup" "pktsdirs"))
(pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f)))
pktsdir))
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.mtutilrc")))
(if (common:file-exists? debugcontrolf)
(load debugcontrolf)))
(if (args:get-arg "-log") ;; redirect the log always when a server
(handle-exceptions
exn
(begin
(print "ERROR: Failed to switch to log output. " ((condition-property-accessor 'exn 'message) exn))
)
(let* ((tl (args:get-arg "-log")) ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified
(logf (args:get-arg "-log")) ;; use -log unless we are a server, then craft a logfile name
(oup (open-logfile logf)))
;(if (not (args:get-arg "-log"))
; (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log
(print *default-log-port* "Sending log output to " logf)
(set! *default-log-port* oup)
)))
(if *action*
(case (string->symbol *action*)
((run remove rerun rerun-clean rerun-all set-ss archive kill list)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(area (args:get-arg "-area")) ;; look up the area to dispatch to from [areas] section
|
| ︙ | | | ︙ | |
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
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
|
((sqlite3schema)
(let* ((install-home (common:get-install-area))
(schema-file (conc install-home "/share/db/mt-sqlite3.sql")))
(if (common:file-exists? schema-file)
(system (conc "/bin/cat " schema-file)))))
((junk)
(rmt:get-keys))))))
((tsend)
(print "ERROR: missing data to send to trigger listeners")
(let* ((msg (car remargs))
(mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(listeners (configf:get-section mtconf "listeners"))
(prev-seen (make-hash-table))) ;; catch duplicates
(for-each
(lambda (listener)
(let ((host-port (car listener))
(remdat (cdr listener)))
(print "sending " msg " to " host-port)
(open-send-close-nn host-port msg timeout: 2)))
listeners))))
((tlisten)
(if (null? remargs)
(print "ERROR: useage for tlisten is \"mtutil tlisten portnum\"")
(let ((portnum (string->number (car remargs))))
(if (not portnum)
(print "ERROR: the portnumber parameter must be a number, you gave: " (car remargs))
(begin
(if (not (is-port-in-use portnum))
(let* ((rep (start-nn-server portnum))
(mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(script (configf:lookup mtconf "listener" "script")))
(print "Listening on port " portnum " for messages")
(set-signal-handler! signal/int special-signal-handler)
(set-signal-handler! signal/term special-signal-handler)
(let loop ((instr (nn-recv rep)))
(print "received " instr ", running \"" script " " instr "\"")
(system (conc script " '" instr "'"))
(nn-send rep "ok")
|
|
|
|
>
>
>
>
|
|
>
>
>
>
|
|
|
>
>
>
>
>
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
|
>
>
>
>
|
>
>
|
>
>
>
>
|
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
|
((sqlite3schema)
(let* ((install-home (common:get-install-area))
(schema-file (conc install-home "/share/db/mt-sqlite3.sql")))
(if (common:file-exists? schema-file)
(system (conc "/bin/cat " schema-file)))))
((junk)
(rmt:get-keys))))))
((tsend)
(if (null? remargs)
(print "ERROR: missing data to send to trigger listeners")
(let* ((msg (car remargs))
(mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(time-out (or (string->number (args:get-arg "-time-out")) 5))
(listeners (configf:get-section mtconf "listeners"))
(user-info (user-information (current-user-id)))
(prev-seen (make-hash-table))) ;; catch duplicates
(if user-info
(begin
(for-each
(lambda (listener)
(let ((host-port (car listener))
(attrib (val->alist (cadr listener))))
(if (and (equal? msg "time-to-die") (not (can-user-kill-listner user-info attrib)))
(begin
(debug:print-error 0 *default-log-port* "User " (car user-info) " is not allowed to send message '" msg"'")
(exit 1)))
(print "sending " msg " to " host-port )
(open-send-close-nn host-port msg attrib timeout: time-out )))
listeners))
(begin
(debug:print-error 0 *default-log-port* "Could not Identify executing user. Will not send any message")
(exit 1))))))
((tlisten)
(if (null? remargs)
(print "ERROR: useage for tlisten is \"mtutil tlisten portnum\"")
(let ((portnum (string->number (car remargs))))
(if (not portnum)
(print "ERROR: the portnumber parameter must be a number, you gave: " (car remargs))
(begin
(if (not (is-port-in-use portnum))
(let* ((rep (start-nn-server portnum))
(mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(contact (configf:lookup mtconf "listener" "owner"))
(script (configf:lookup mtconf "listener" "script")))
(print "Listening on port " portnum " for messages.")
(set-signal-handler! signal/int (lambda (signum)
(set! *time-to-exit* #t)
(debug:print-error 0 *default-log-port* "Received signal " signum " sending email befor exiting !!")
(let ((email-body (mtut:stml->string (s:body
(s:p (conc "Received signal " signum ". Lister has been terminated on host " (get-environment-variable "HOST") ". "))))))
(sendmail "priyanka.j.hatwalne@intel.com" "Listner has been terminated." email-body use_html: #t))
(exit)))
(set-signal-handler! signal/term (lambda (signum)
(set! *time-to-exit* #t)
(debug:print-error 0 *default-log-port* "Received signal " signum " sending email befor exiting !!")
(let ((email-body (mtut:stml->string (s:body
(s:p (conc "Received signal " signum ". Lister has been terminated on host " (get-environment-variable "HOST") ". "))))))
(sendmail "priyanka.j.hatwalne@intel.com" "Listner has been terminated." email-body use_html: #t))
(exit)))
;(set-signal-handler! signal/term special-signal-handler)
(let loop ((instr (nn-recv rep)))
(nn-send rep "ok")
(let ((ctime (date->string (current-date))))
(if (equal? instr "time-to-die")
(begin
(debug:print 0 *default-log-port* ctime " received '" instr "'. Time to sucide." )
(let ((pid (current-process-id)))
(debug:print 0 *default-log-port* "Killing current process (pid=" pid ")")
(system (conc "kill " pid))))
(begin
(debug:print 0 *default-log-port* ctime " received " instr )
;(nn-send rep "ok")
(if (not (equal? instr "ping"))
(begin
(debug:print 0 *default-log-port* ctime " running \"" script " " instr "\"")
(system (conc script " '" instr "'")))))))
(loop (nn-recv rep))))
(print "ERROR: Port " portnum " already in use. Try another port")))))))
((gather) ;; gather all area db's into /tmp/$USER_megatest/alldbs
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(areas (get-area-names mtconf)))
(print "areas: " areas)))
|
| ︙ | | | ︙ | |