Megatest

xterm : sd
	(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 $(OFILES)
	csc $(CSCOPTS) sretrieve.scm $(OFILES) -o datashare-testing/sretrieve





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 \
             srfi-1 posix regex regex-case srfi-69 

$(PREFIX)/bin/.$(ARCHSTR)/ndboard : ndboard
	$(INSTALL) ndboard $(PREFIX)/bin/.$(ARCHSTR)/ndboard

$(PREFIX)/bin/.$(ARCHSTR)/mtut : mtut
	$(INSTALL) mtut $(PREFIX)/bin/.$(ARCHSTR)/mtut

install-mtut : 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

#$(PREFIX)/bin/.$(ARCHSTR)/mdboard : multi-dboard
#	$(INSTALL) multi-dboard $(PREFIX)/bin/.$(ARCHSTR)/mdboard

;; (include "common.scm")
;; (include "megatest-version.scm")

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

;; 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)
  (hash-table-set! *runname-mappers* name proc))
(define (add-area-checker name proc)

    ("-load"            . #f)  ;; load and exectute a scheme file
    ("-log"             . #f)
    ("-override-user"   . #f)
    ("-msg"             . M)
    ("-start-dir"       . S)
    ("-set-vars"        . v)
    ("-config"          . h)
    ("-time-out"        . t)
    ))
(define *switch-keys*
  '(
    ("-h"               . #f)
    ("-help"            . #f)
    ("--help"           . #f)
    ("-manual"          . #f)

     exn
     (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
       (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 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")  
     (let* ((th1  (make-thread (lambda ()
                                 (let ((resp (nn-recv req)))
                                   (nn-close req)
                                   (set! res (if (equal? resp "ok")
                                                 #t
                                                 #f))))
                               "recv thread"))

	  (cond
	   ((and access-types (member action allowed-actions))
	    ;; (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")))
	      (mtconf    (car mtconfdat))
	      (area      (args:get-arg "-area")) ;; look up the area to dispatch to from [areas] section

	       ((sqlite3schema)
		(let* ((install-home (common:get-install-area))
		       (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)
       (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  (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
             (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-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))))
              
             (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 "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)))
                             (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))
              (areas     (get-area-names mtconf)))
         (print "areas: " areas)))

(use scsh-process)

(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 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. 
(include "sauth-paths.scm")
(include "sauth-common.scm")

                  (cmd-args (cddr args)) 
                  (code-obj (get-obj-by-code area)))
           (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)))
              (sauthorize:do-as-calling-user
             (lambda ()
                (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (append (list action area ) cmd-args))))))

 
 
      ((open)