Megatest

Check-in [6bf1d50b66]
Login
Overview
Comment:restored mtutil go by cherry picking f98a3f9de9, a2de50c3ef, c9fbdc272c and ca42565289
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.65
Files: files | file ages | folders
SHA1: 6bf1d50b66b3f759c712bd9afa4db2a79a9e201c
User & Date: mmgraham on 2021-05-24 16:42:59
Other Links: branch diff | manifest | tags
Context
2021-05-24
16:46
Changed version to v1.6586 check-in: cb6232575a user: mmgraham tags: v1.65
16:42
restored mtutil go by cherry picking f98a3f9de9, a2de50c3ef, c9fbdc272c and ca42565289 check-in: 6bf1d50b66 user: mmgraham tags: v1.65
2021-04-29
15:13
updated version to v1.6585 check-in: b665f476b3 user: mmgraham tags: v1.65, v1.6585
Changes

Modified configf.scm from [d727d54436] to [e25d127827].

533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
;; redefines
(define config-lookup configf:lookup)
(define configf:read-file read-config)

;; safely look up a value that is expected to be a number, return
;; a default (#f unless provided)
;;
(define (configf:lookup-number cfdat section varname #!key (default #f))
  (let* ((val (configf:lookup *configdat* section varname))
         (res (if val
                  (string->number (string-substitute "\\s+" "" val #t))
                  #f)))
    (cond
     (res  res)
     (val  (debug:print 0 *default-log-port* "ERROR: no number found for [" section "], " varname ", got: " val))
     (else default))))







|
|







533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
;; redefines
(define config-lookup configf:lookup)
(define configf:read-file read-config)

;; safely look up a value that is expected to be a number, return
;; a default (#f unless provided)
;;
(define (configf:lookup-number cfgdat section varname #!key (default #f))
  (let* ((val (configf:lookup cfgdat section varname))
         (res (if val
                  (string->number (string-substitute "\\s+" "" val #t))
                  #f)))
    (cond
     (res  res)
     (val  (debug:print 0 *default-log-port* "ERROR: no number found for [" section "], " varname ", got: " val))
     (else default))))

Modified mtut.scm from [ead30f316f] to [413cf26858].

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
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
	 ;;    (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)))
	 (print "Using period="period" and rest time="rest-time)
	 (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)
	    ;; determine if I'm the boss
	    (if (file-exists? "mtutil-go.pid")
		(begin
		  (print "ERROR: mtutil go is already running under host and pid " (with-input-from-file "mtutil-go.pid" read-line)
			 ". Please kill that process and remove the file \"mutil-go.pid\" and try again.")
		  (exit)))
	    (with-output-to-file "mtutil-go.pid" (lambda ()(print (get-host-name) " " (current-process-id))))
	    (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")
		  (begin
		    (print "File do-not-run-mtutil-go exists, exiting.")
		    (delete-file* "mtutil-go.pid")
		    (exit)))
	      (let ((delta (- this-run last-run)))
		(if (>= delta period)
		    (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
			   (mtconf    (car mtconfdat)))
		      (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.")
		      (loop this-run (current-seconds)))
		    (let ((now (current-seconds)))
		      (print "Sleeping " rest-time " seconds, next run in aproximately " (- period (- now last-run)) " seconds")
		      (thread-sleep! rest-time)
		      (loop last-run (current-seconds))))))
	    (delete-file* "mtutil-go.pid")))))
      ;; 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)))







<
<
<

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
>
|
>
|
>
>
|
|
|
|
|
>
|
>
|
>
>
|
|

|
|







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
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
                                   )

                                  )

                                )))
                           (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)))