︙ | | | ︙ | |
152
153
154
155
156
157
158
159
160
161
162
163
164
165
|
Queries:
show [areas|contours... ] : show areas, contours or other section from megatest.config
gendot : generate a graphviz dot file from pkts.
Contour actions:
process : runs import, rungen and dispatch
Trigger propagation actions:
tsend a=b,c=d... : send trigger info to all recpients in the [listeners] section
tlisten -port N : listen for trigger info on port N
Selectors
-immediate : apply this action immediately, default is to queue up actions
|
>
|
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
|
Queries:
show [areas|contours... ] : show areas, contours or other section from megatest.config
gendot : generate a graphviz dot file from pkts.
Contour actions:
process : runs import, rungen and dispatch
go : runs import, rungen and dispatch every five minutes forever
Trigger propagation actions:
tsend a=b,c=d... : send trigger info to all recpients in the [listeners] section
tlisten -port N : listen for trigger info on port N
Selectors
-immediate : apply this action immediately, default is to queue up actions
|
︙ | | | ︙ | |
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
|
(handle-exceptions
exn
(begin
(print-call-chain)
(print "FAILED TO RUN RUNNAME MAPPER " callname " FOR AREA " area)
(print " message: " ((condition-property-accessor 'exn 'message) exn))
runname)
(print "(mapper " (string-intersperse (list runkey runname area area-path reason contour mode-patt) ", ") ")")
(mapper runkey runname area area-path reason contour mode-patt))
(case callname
((auto #f) runname)
(else runtrans)))))
(new-target target) ;; I believe we will want target manipulation here .. (map-targets xlatr-key runkey area contour))
(actual-action (if action
(if (equal? action "sync-prepend")
|
|
|
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
|
(handle-exceptions
exn
(begin
(print-call-chain)
(print "FAILED TO RUN RUNNAME MAPPER " callname " FOR AREA " area)
(print " message: " ((condition-property-accessor 'exn 'message) exn))
runname)
(print "(mapper " (string-intersperse (map conc (list runkey runname area area-path reason contour mode-patt)) ", ") ")")
(mapper runkey runname area area-path reason contour mode-patt))
(case callname
((auto #f) runname)
(else runtrans)))))
(new-target target) ;; I believe we will want target manipulation here .. (map-targets xlatr-key runkey area contour))
(actual-action (if action
(if (equal? action "sync-prepend")
|
︙ | | | ︙ | |
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
|
;; (if (not (member key *legal-params*))
;; (hash-table-delete! adjargs key))) ;; we need to delete any params intended for mtutil
;; (hash-table-keys adjargs))
(let-values (((uuid pkt)
(command-line->pkt *action* adjargs #f area-path: area-path new-ss: new-ss)))
(print "run log @ " (conc (current-directory) "/" uuid "-" *action* ".log"))
(write-pkt pktsdir uuid pkt))))
((dispatch import rungen process)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(toppath (configf:lookup mtconf "scratchdat" "toppath")))
(case (string->symbol *action*)
((process) (begin
(common:load-pkts-to-db mtconf)
(generate-run-pkts mtconf toppath)
(common:load-pkts-to-db mtconf)
(dispatch-commands mtconf toppath)))
((import) (common:load-pkts-to-db mtconf)) ;; import pkts
((rungen) (generate-run-pkts mtconf toppath))
((dispatch) (dispatch-commands mtconf toppath)))))
;; misc
((show)
(if (> (length remargs) 0)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(sect-dat (configf:get-section mtconf (car remargs))))
(if sect-dat
|
|
|
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
1611
1612
1613
1614
1615
1616
1617
1618
1619
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
|
;; (if (not (member key *legal-params*))
;; (hash-table-delete! adjargs key))) ;; we need to delete any params intended for mtutil
;; (hash-table-keys adjargs))
(let-values (((uuid pkt)
(command-line->pkt *action* adjargs #f area-path: area-path new-ss: new-ss)))
(print "run log @ " (conc (current-directory) "/" uuid "-" *action* ".log"))
(write-pkt pktsdir uuid pkt))))
((dispatch import rungen process go)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(toppath (configf:lookup mtconf "scratchdat" "toppath"))
(period (configf:lookup-number mtconf "mtutil" "autorun-period" default: 300))
(rest-time (configf:lookup-number mtconf "mtutil" "autorun-rest" default: 30)))
(case (string->symbol *action*)
((process) (begin
(common:load-pkts-to-db mtconf)
(generate-run-pkts mtconf toppath)
(common:load-pkts-to-db mtconf)
(dispatch-commands mtconf toppath)))
((import) (common:load-pkts-to-db mtconf)) ;; import pkts
((rungen) (generate-run-pkts mtconf toppath))
((dispatch) (dispatch-commands mtconf toppath))
;; [mtutil]
;; # approximate interval between run processing in mtutil (seconds)
;; autorun-period 300
;; # minimal rest period between processing
;; autorun-rest 30
((go) (begin
(print "Starting long running import, rungen, and process loop")
(if (file-exists? "do-not-run-mtutil-go")
(begin
(print "NOTE: Removing flag file "(current-directory)"/do-not-run-mtutil-go")
(delete-file* "do-not-run-mtutil-go")))
(let loop ((last-run (- (current-seconds) (+ period 10))) ;; fake out first time in
(this-run (current-seconds)))
(if (file-exists? "do-not-run-mtutil-go")
(exit))
(let ((delta (- this-run last-run)))
(if (>= delta period)
(begin
(print "Running import at " (current-seconds))
(common:load-pkts-to-db mtconf)
(print "Running generate run pkts at " (current-seconds))
(generate-run-pkts mtconf toppath)
(print "Running run dispatch at " (current-seconds))
(common:load-pkts-to-db mtconf)
(dispatch-commands mtconf toppath)
(print "Done running import, generate, and dispatch done in " (- (current-seconds) this-run))
(print "NOTE: touch " (current-directory) "/do-not-run-mtutil-go to kill this runner.")
))
(thread-sleep! rest-time))
(loop this-run (current-seconds)))))
)))
;; misc
((show)
(if (> (length remargs) 0)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(sect-dat (configf:get-section mtconf (car remargs))))
(if sect-dat
|
︙ | | | ︙ | |
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
|
)
)
)))
(loop (nn-recv rep))))
(print "ERROR: Port " portnum " already in use. Try another port")))))))
((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 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 "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)))
|
<
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
>
|
>
|
>
>
|
|
|
|
|
>
|
>
|
>
>
|
|
|
|
|
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
|
)
)
)))
(loop (nn-recv rep))))
(print "ERROR: Port " portnum " already in use. Try another port")))))))
((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 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 "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)))
|
︙ | | | ︙ | |