| ︙ | | | ︙ | |
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
|
(prefix dbi dbi:)
nanomsg)
(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
(declare (uses configf))
;; (declare (uses rmt))
|
|
|
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
|
(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)
|
| ︙ | | | ︙ | |
138
139
140
141
142
143
144
145
146
147
148
149
150
151
|
-version : print megatest version (currently " megatest-version ")
Run management:
run : initiate or resume a run, already completed and in-progress
tests are not affected.
rerun-clean : clean and rerun all not completed pass/fail tests
rerun-all : clean and rerun entire run
remove : remove runs
set-ss : set state/status
archive : compress and move test data to archive disk
kill : stop tests or entire runs
db : database utilities
Queries:
|
>
>
|
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
|
-version : print megatest version (currently " megatest-version ")
Run management:
run : initiate or resume a run, already completed and in-progress
tests are not affected.
rerun-clean : clean and rerun all not completed pass/fail tests
rerun-all : clean and rerun entire run
kill-run : kill all tests in run
kill-rerun : kill all tests in run and restart non-completed tests
remove : remove runs
set-ss : set state/status
archive : compress and move test data to archive disk
kill : stop tests or entire runs
db : database utilities
Queries:
|
| ︙ | | | ︙ | |
245
246
247
248
249
250
251
252
253
254
255
256
257
258
|
))
;; alist to map actions to old megatest commands
(define *action-keys*
'((run . "-run")
(rerun-clean . "-rerun-clean")
(rerun-all . "-rerun-all")
(sync . "")
(archive . "-archive")
(set-ss . "-set-state-status")
(remove . "-remove-runs")))
;; manually keep this list updated from the keys to
;; the case *action* near the end of this file.
|
>
>
|
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
|
))
;; alist to map actions to old megatest commands
(define *action-keys*
'((run . "-run")
(rerun-clean . "-rerun-clean")
(rerun-all . "-rerun-all")
(kill-run . "-kill-runs")
(kill-rerun . "-kill-rerun")
(sync . "")
(archive . "-archive")
(set-ss . "-set-state-status")
(remove . "-remove-runs")))
;; manually keep this list updated from the keys to
;; the case *action* near the end of this file.
|
| ︙ | | | ︙ | |
490
491
492
493
494
495
496
497
498
499
500
501
502
503
|
(define-inline (decode data)
(with-input-from-string
data
(lambda ()
(read))))
(define (is-port-in-use port-num)
(let* ((ret #f))
(let-values (((inp oup pid)
(process "netstat" (list "-tulpn" ))))
(let loop ((inl (read-line inp)))
(if (not (eof-object? inl))
(begin
|
>
>
|
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
|
(define-inline (decode data)
(with-input-from-string
data
(lambda ()
(read))))
;; moved to portlogger - TODO: remove from here and get from portlogger
;;
(define (is-port-in-use port-num)
(let* ((ret #f))
(let-values (((inp oup pid)
(process "netstat" (list "-tulpn" ))))
(let loop ((inl (read-line inp)))
(if (not (eof-object? inl))
(begin
|
| ︙ | | | ︙ | |
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
|
; (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
(areasec (if area (configf:lookup mtconf "areas" area) #f))
(areadat (if areasec (common:val->alist areasec) #f))
(area-path (if areadat (alist-ref 'path areadat) #f))
(pktsdirs (configf:lookup mtconf "setup" "pktsdirs"))
|
|
|
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
|
; (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 kill-run kill-rerun)
(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
(areasec (if area (configf:lookup mtconf "areas" area) #f))
(areadat (if areasec (common:val->alist areasec) #f))
(area-path (if areadat (alist-ref 'path areadat) #f))
(pktsdirs (configf:lookup mtconf "setup" "pktsdirs"))
|
| ︙ | | | ︙ | |
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
|
(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 contact "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 contact "Listner has been terminated." email-body use_html: #t))
(exit)))
;(set-signal-handler! signal/term special-signal-handler)
;;(nn-send rep "3.9")
(with-input-from-pipe (conc "/usr/bin/uptime | cut -d':' -f4 | awk '{print $1}' | cut -d',' -f1")
(lambda()
(let loop ((inl (read-line)))
(if (not (eof-object? inl))
(begin
;;(print "fdk73: " inl ":")
;;(set! current-list-ciaf (append! current-list-ciaf (list (string-substitute "\\s+$" "" inl))))
(nn-send rep inl)
(loop(read-line)))
))
)
)
;;(print (isys "/usr/bin/uptime" foreach-stdout-thunk: foreach-stdout))
(let ((ctime (date->string (current-date))))
(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 "'"))
(process-run script (list instr ))
(debug:print 0 *default-log-port* ctime " done" ))
(begin
(if (not (equal? instr "load"))
(print "Checking load")
)
)
)
)))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
|
(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 contact "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 contact "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 "3.9")
(with-input-from-pipe (conc "/usr/bin/uptime | cut -d':' -f4 | awk '{print $1}' | cut -d',' -f1")
(lambda()
(let loop ((inl (read-line)))
(if (not (eof-object? inl))
(begin
;;(print "fdk73: " inl ":")
;;(set! current-list-ciaf (append! current-list-ciaf (list (string-substitute "\\s+$" "" inl))))
(nn-send rep inl)
(loop(read-line)))
))))
;;(print (isys "/usr/bin/uptime" foreach-stdout-thunk: foreach-stdout))
(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 "'"))
(process-run script (list instr ))
(debug:print 0 *default-log-port* ctime " done" ))
(begin
(if (not (equal? instr "load"))
(print "Checking load")
)
)
)
)))
(loop (nn-recv rep))))
(print "ERROR: Port " portnum " already in use. Try another port")))))))
((tlisten)
|
| ︙ | | | ︙ | |