| ︙ | | | ︙ | |
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.
|
| ︙ | | | ︙ | |
569
570
571
572
573
574
575
576
577
578
579
580
581
582
|
(thread-sleep! timeout)
(thread-terminate! th1))
"timer thread")))
(thread-start! th1)
(thread-start! th2)
(thread-join! th1)
res))))
;;======================================================================
;; Runs
;;======================================================================
;; make a runname
;;
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
|
(thread-sleep! timeout)
(thread-terminate! th1))
"timer thread")))
(thread-start! th1)
(thread-start! th2)
(thread-join! th1)
res))))
(define (open-send-receive-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")
;; receive code here
;;(print (nn-recv req))
(let* ((th1 (make-thread (lambda ()
(let ((resp (nn-recv req)))
(nn-close req)
(print resp)
(set! res (if (equal? resp "ok")
#t
#f))))
"recv thread"))
(th2 (make-thread (lambda ()
(thread-sleep! timeout)
(thread-terminate! th1))
"timer thread")))
(thread-start! th1)
(thread-start! th2)
(thread-join! th1)
res))))
;;======================================================================
;; Runs
;;======================================================================
;; make a runname
;;
|
| ︙ | | | ︙ | |
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
|
(last-sync (if (null? synctimes) ;; if '() then it has never been run, else get the max
0
(apply max (map cdr synctimes))))
)
(let ((delta (lambda (x)
(round (/ (- (current-seconds) x) 60)))))
(print "runkey: " runkey ", ruletype: " ruletype ", action: " action ", last-run: " last-run " time since; last-run: " (delta last-run) ", last-sync: " (delta last-sync)))
(print "val-alist=" val-alist " runtrans=" runtrans)
;; look in runstarts for matching runs by target and contour
;; get the timestamp for when that run started and pass it
;; to the rule logic here where "ruletype" will be applied
;; if it comes back "changed" then proceed to register the runs
(case (string->symbol (or ruletype "no-such-rule"))
|
>
>
|
|
>
>
|
>
>
|
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
|
(last-sync (if (null? synctimes) ;; if '() then it has never been run, else get the max
0
(apply max (map cdr synctimes))))
)
(let ((delta (lambda (x)
(round (/ (- (current-seconds) x) 60)))))
(if (args:get-arg "-target")
(if (string= (args:get-arg "-target") runkey)
(begin (print "runkey: " runkey ", ruletype: " ruletype ", action: " action ", last-run: " last-run " time since; last-run: " (delta last-run) ", last-sync: " (delta last-sync))
(print "val-alist=" val-alist " runtrans=" runtrans))
(if #f (print "skipping: " runkey)))
(begin (print "runkey: " runkey ", ruletype: " ruletype ", action: " action ", last-run: " last-run " time since; last-run: " (delta last-run) ", last-sync: " (delta last-sync))
(print "val-alist=" val-alist " runtrans=" runtrans))
))
;; look in runstarts for matching runs by target and contour
;; get the timestamp for when that run started and pass it
;; to the rule logic here where "ruletype" will be applied
;; if it comes back "changed" then proceed to register the runs
(case (string->symbol (or ruletype "no-such-rule"))
|
| ︙ | | | ︙ | |
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
|
;; the script is called like this: scriptname contour runkey std-runname action extra_param1 extra_param2 ...
(for-each
(lambda (cmd)
;;(print "cmd: " cmd)
;;(print "Areas: " all-areas)
(for-each
(lambda (area)
(if (area-allowed? area "area-needs-to-be-run" runkey contour #f) ;; is this area to be handled (from areas=a,b,c OR using areafn=abcfn and *area-checks* ...)
(with-input-from-pipe cmd read-lines))))
(if (and res (not (null? res)))
(let* ((parts (string-split (car res))) ;;
(rem-lines (cdr res))
(num-parts (length parts))
(last-change (string->number (if (> num-parts 0)(car parts) "abc"))) ;; force no run if not a number returned
(new-target (if (> num-parts 1)
(cadr parts)
|
>
>
>
>
|
|
>
>
>
>
>
>
>
>
|
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
|
;; the script is called like this: scriptname contour runkey std-runname action extra_param1 extra_param2 ...
(for-each
(lambda (cmd)
;;(print "cmd: " cmd)
;;(print "Areas: " all-areas)
(for-each
(lambda (area)
;Add code to check whether area is valid
(if
(if (args:get-arg "-target")
(if (string= (args:get-arg "-target") runkey) (area-allowed? area "area-needs-to-be-run" runkey contour #f) #f)
(area-allowed? area "area-needs-to-be-run" runkey contour #f))
(let* ((script (car cmd))
(params (cdr cmd))
(cmd (conc script " " contour " " area " " runkey " " std-runname " " action " " params))
(res (handle-exceptions
exn
#f
(print "Running " cmd)
(with-input-from-pipe cmd read-lines)))
(cval (or (configf:lookup mtconf "contours" contour) ""))
(cval-alist (common:val->alist cval)) ;; BEWARE ... NOT the same val-alist as above!
;;(areas (val-alist->areas cval-alist))
(selector (alist-ref 'selector cval-alist))
(mode-tag (and selector (string-split-fields "/" selector #:infix)))
(mode-patt (and mode-tag (if (eq? (length mode-tag) 2)(cadr mode-tag) #f)))
(tag-expr (and mode-tag (if (null? mode-tag) #f (car mode-tag))))
)
(if (and res (not (null? res)))
(let* ((parts (string-split (car res))) ;;
(rem-lines (cdr res))
(num-parts (length parts))
(last-change (string->number (if (> num-parts 0)(car parts) "abc"))) ;; force no run if not a number returned
(new-target (if (> num-parts 1)
(cadr parts)
|
| ︙ | | | ︙ | |
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
|
(starttimes (common:get-pkt-times rspkts)) ;; sort by age (youngest first) and delete duplicates by target
(last-run (if (null? starttimes) ;; if '() then it has never been run, else get the max
0
(apply max (map cdr starttimes))))
;; (last-run 9) ;; I think we can do a more valid calculation for this based on the run started packets for this particular area and target
(reason "Area-script-triggered")
(mode-patt #f)
(tag-expr #f)
(sched #f)
(message (if (null? rem-lines)
cmd
(string-intersperse rem-lines "-")))
(need-run (> last-change last-run)))
(print "last-change: " last-change " last-run: " last-run " need-run: " need-run)
(if need-run
|
|
|
|
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
|
(starttimes (common:get-pkt-times rspkts)) ;; sort by age (youngest first) and delete duplicates by target
(last-run (if (null? starttimes) ;; if '() then it has never been run, else get the max
0
(apply max (map cdr starttimes))))
;; (last-run 9) ;; I think we can do a more valid calculation for this based on the run started packets for this particular area and target
(reason "Area-script-triggered")
;;(mode-patt #f)
;;(tag-expr #f)
(sched #f)
(message (if (null? rem-lines)
cmd
(string-intersperse rem-lines "-")))
(need-run (> last-change last-run)))
(print "last-change: " last-change " last-run: " last-run " need-run: " need-run)
(if need-run
|
| ︙ | | | ︙ | |
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
|
(aval-alist (common:val->alist aval))
(targets (map-targets mtconf aval-alist runkey area contour)))
(pp targets)
(for-each (lambda (target) (create-run-pkt mtconf action area runkey target new-runname mode-patt
tag-expr pktsdir reason contour sched dbdest append
runtrans)) targets)
;;(create-run-pkt mtconf action area runkey target runname
;; pktsdir reason contour dbdest append
;; runtrans)
(print "key-msg: " key-msg)
;;(push-run-spec torun contour
;; (if optional ;; we need to be able to differentiate same contour, different behavior.
;; (conc runkey ":" optional) ;; NOTE: NOT COMPLETELY IMPLEMENTED. DO NOT USE
;; runkey)
;; key-msg)
))))))) all-areas)
) val-alist)) ;; iterate over the param split by ;\s*
;; fossil scm based triggers
;;
((fossil)
(for-each
(lambda (fspec)
|
>
|
|
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
|
(aval-alist (common:val->alist aval))
(targets (map-targets mtconf aval-alist runkey area contour)))
(pp targets)
(for-each (lambda (target) (create-run-pkt mtconf action area runkey target new-runname mode-patt
tag-expr pktsdir reason contour sched dbdest append
runtrans)) targets)
;; Add filter for targets
;;(create-run-pkt mtconf action area runkey target runname
;; pktsdir reason contour dbdest append
;; runtrans)
(print "key-msg: " key-msg)
;;(push-run-spec torun contour
;; (if optional ;; we need to be able to differentiate same contour, different behavior.
;; (conc runkey ":" optional) ;; NOTE: NOT COMPLETELY IMPLEMENTED. DO NOT USE
;; runkey)
;; key-msg)
))))))) (filter (lambda (x) (if (not (args:get-arg "-area")) #t (if (string= x (args:get-arg "-area")) #t #f))) all-areas))
) val-alist)) ;; iterate over the param split by ;\s*
;; fossil scm based triggers
;;
((fossil)
(for-each
(lambda (fspec)
|
| ︙ | | | ︙ | |
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
|
; (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"))
|
|
|
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
|
; (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"))
|
| ︙ | | | ︙ | |
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
|
(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))))))
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
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
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
1695
1696
1697
1698
1699
1700
1701
|
(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))))))
((tquery)
(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 (if (args:get-arg "-time-out")
(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-receive-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))))))
((tquerylisten)
(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 "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)
(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))
|
| ︙ | | | ︙ | |
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
|
(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")
;(system (conc script " '" instr "'"))
(process-run script (list (conc "'" instr "'")))
(debug:print 0 *default-log-port* ctime " done" ))))))
(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)))
|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
|
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
|
(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")))))))
((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)))
|
| ︙ | | | ︙ | |