Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -358,19 +358,16 @@ (export BASEPATH=/tmp/$(USER)/basepath ; export PATH="$(PWD)/datashare-testing:$(PATH)" ; xterm &) datashare-testing/spublish : spublish.scm $(OFILES) csc $(CSCOPTS) spublish.scm $(OFILES) -o datashare-testing/spublish -datashare-testing/sretrieve : sretrieve.scm megatest-version.o margs.o configf.o process.o - csc $(CSCOPTS) sretrieve.scm megatest-version.o margs.o configf.o process.o -o datashare-testing/sretrieve - -datashare-testing/sauthorize : sretrieve.scm megatest-version.o margs.o configf.o process.o common.o - csc sauthorize.scm megatest-version.o margs.o configf.o process.o common.o -o datashare-testing/sauthorize +datashare-testing/sretrieve : sretrieve.scm $(OFILES) + csc $(CSCOPTS) sretrieve.scm $(OFILES) -o datashare-testing/sretrieve -datashare-testing/sauthorize : sretrieve.scm megatest-version.o margs.o configf.o process.o common.o - csc sauthorize.scm megatest-version.o margs.o configf.o process.o common.o -o datashare-testing/sauthorize +datashare-testing/sauthorize : sauthorize.scm $(OFILES) + csc $(CSCOPTS) sauthorize.scm $(OFILES) -o datashare-testing/sauthorize sretrieve/sretrieve : datashare-testing/sretrieve csc $(CSCOPTS) -deploy -deployed sretrieve.scm megatest-version.o margs.o configf.o process.o chicken-install -keep-installed $(PROXY) -deploy -prefix sretrieve defstruct srfi-18 format sql-de-lite \ Index: Makefile.deploy ================================================================== --- Makefile.deploy +++ Makefile.deploy @@ -246,15 +246,18 @@ $(PREFIX)/bin/.$(ARCHSTR)/mtut : mtut $(INSTALL) mtut $(PREFIX)/bin/.$(ARCHSTR)/mtut install-mtut : mtut - $(INSTALL) mtut $(PREFIX)/bin/mtut + echo $(INSTALL) + #$(INSTALL) mtut $(PREFIX)/bin/mtut $(PREFIX)/bin/mtutil : $(PREFIX)/bin/.$(ARCHSTR)/mtut utils/mk_wrapper utils/mk_wrapper $(PREFIX) mtut $(PREFIX)/bin/mtutil chmod a+x $(PREFIX)/bin/mtutil + +mtutil: $(PREFIX)/bin/mtutil $(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard utils/mk_wrapper utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard chmod a+x $(PREFIX)/bin/newdashboard Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -21,19 +21,21 @@ ;; 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 + 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) @@ -40,10 +42,17 @@ ;; 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) @@ -214,10 +223,11 @@ ("-override-user" . #f) ("-msg" . M) ("-start-dir" . S) ("-set-vars" . v) ("-config" . h) + ("-time-out" . t) )) (define *switch-keys* '( ("-h" . #f) ("-help" . #f) @@ -506,25 +516,48 @@ (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 #!key (timeout 3)) ;; default timeout is 3 seconds +(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)) + (res #f) + (contacts (alist-ref 'contact attrib)) + (mode (alist-ref 'mode attrib))) (handle-exceptions exn (let ((emsg ((condition-property-accessor 'exn 'message) exn))) - (print "ERROR: Failed to connect/send to " uri " message was \"" emsg "\"") + ;; 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) - ;; NEED timer here! + (print "Request Sent") (let* ((th1 (make-thread (lambda () (let ((resp (nn-recv req))) (nn-close req) (set! res (if (equal? resp "ok") #t @@ -1193,19 +1226,46 @@ ;; (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"))) @@ -1311,25 +1371,37 @@ (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) + ((tsend) (if (null? remargs) - (print "ERROR: missing data to send to trigger listeners") - (let* ((msg (car 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 - (for-each + (if user-info + (begin + (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)))) + (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)))) @@ -1338,19 +1410,46 @@ (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 special-signal-handler) - (set-signal-handler! signal/term special-signal-handler) + (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))) - (print "received " instr ", running \"" script " " instr "\"") - (system (conc script " '" instr "'")) - (nn-send rep "ok") + (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)) Index: sauthorize.scm ================================================================== --- sauthorize.scm +++ sauthorize.scm @@ -23,13 +23,12 @@ (use srfi-18) (use srfi-19) (use refdb) (use sql-de-lite srfi-1 posix regex regex-case srfi-69) -(declare (uses common)) - -(declare (uses configf)) +;(declare (uses common)) +;(declare (uses configf)) (declare (uses margs)) (declare (uses megatest-version)) (include "megatest-fossil-hash.scm") ;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm. @@ -487,11 +486,11 @@ (if (or (null? code-obj) (not (exe-exist (cadr code-obj) "retrieve"))) (begin (print "Area " area " is not open for reading!!") (exit 1))) - (print (conc *exe-path* "/retrieve/" (cadr code-obj) " " action " " area " " (string-join cmd-args))) + ;(print (conc *exe-path* "/retrieve/" (cadr code-obj) " " action " " area " " (string-join cmd-args))) (sauthorize:do-as-calling-user (lambda () (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (append (list action area ) cmd-args))))))