Megatest

;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================

(declare (unit adjutant))
;; (declare (unit adjutant))

(module adjutant *

(import scheme chicken data-structures extras files)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69
(import scheme chicken.base)
(import (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69
	md5 message-digest
	regex srfi-1)

(define (adjutant-run)
  (print "Running the adjutant!"))

)

;; 
;;======================================================================
;; 
;;======================================================================

;; NOT CURRENTLY USED
;;
(define (archive:main linktree target runname testname itempath options)
  (let ((testdir (conc linktree "/" target "/" runname "/" testname "/" itempatt))
	(flavor  'plain) ;; type of machine to run jobs on
	(maxload 1.5)   ;; max allowed load for this work
	(adisks  (archive:get-archive-disks)))
    ;; get testdir size
    ;;   - hand off du to job mgr
    (if (and (common:file-exists? testdir)
	     (file-writable? testdir))
	(let* ((dused  (jobrunner:run-job 
			flavor  ;; machine type
			maxload ;; max allowed load
			'()     ;; prevars - environment vars to set for the job
			common:get-disk-space-used  ;; if a proc call it, if a string it is a unix command
			(list testdir)))
	       (apath  (archive:get-archive testname itempath dused)))
	  (jobrunner:run-job
	   flavor
	   maxload
	   '()
	   archive:run-bup
	   (list testdir apath))))))
;; (define (archive:main linktree target runname testname itempath options)
;;   (let ((testdir (conc linktree "/" target "/" runname "/" testname "/" itempath))
;; 	(flavor  'plain) ;; type of machine to run jobs on
;; 	(maxload 1.5)   ;; max allowed load for this work
;; 	(adisks  (archive:get-archive-disks)))
;;     ;; get testdir size
;;     ;;   - hand off du to job mgr
;;     (if (and (common:file-exists? testdir)
;; 	     (file-writable? testdir))
;; 	(let* ((dused  (jobrunner:run-job 
;; 			flavor  ;; machine type
;; 			maxload ;; max allowed load
;; 			'()     ;; prevars - environment vars to set for the job
;; 			common:get-disk-space-used  ;; if a proc call it, if a string it is a unix command
;; 			(list testdir)))
;; 	       (apath  (archive:get-archive testname itempath dused)))
;; 	  (jobrunner:run-job
;; 	   flavor
;; 	   maxload
;; 	   '()
;; 	   archive:run-bup
;; 	   (list testdir apath))))))
	  
;; Get archive disks from megatest.config
;;
(define (archive:get-archive-disks)
  (let ((section (configf:get-section *configdat* "archive-disks")))
    (if section
	section

(define *server-kind-run*   (make-hash-table))
(define *home-host*         #f)
;; (define *total-non-write-delay* 0)
(define *heartbeat-mutex*   (make-mutex))
(define *api-process-request-count* 0)
(define *max-api-process-requests* 0)
(define *server-overloaded*  #f)
(define *writes-total-delay*  0)

;; client
(define *rmt-mutex*         (make-mutex))     ;; remote access calls mutex 

;; RPC transport
(define *rpc:listener*      #f)

;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
;; (include "run_records.scm")
;; 
;; 
;;(rmt:get-test-info-by-id run-id test-id) -> testdat

(define message-window #f)

;; TODO: deprecate me in favor of ezsteps.scm
;;
(define (launch:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat)
  (let* ((stepname       (car ezstep))  ;; do stuff to run the step
	 (stepinfo       (cadr ezstep))
	;; (let ((info (cadr ezstep)))

		(loop (- count 1))))))
    
    (debug:print-info 0 *default-log-port* "Running in directory " test-run-dir)
    (if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps"))
    ;; if ezsteps was defined then we are sure to have at least one step but check anyway
    
    (if (not (> (length ezstepslst) 0))
	(if message-window
	(message-window "ERROR: You can only re-run steps defined via ezsteps")
	    (message-window "ERROR: You can only re-run steps defined via ezsteps")
	    (debug:print 0 *default-log-port* "ERROR: You can only re-run steps defined via ezsteps"))
	(begin
	  (let loop ((ezstep   (car ezstepslst))
		     (tal      (cdr ezstepslst))
                     (status-sym-so-far 'pass)
		     ;;(runflag  #f)
                     (saw-start-step-name #f)) ;; flag used to skip steps when not starting at the beginning
	    (if (or (vector-ref exit-info 1)
		    (equal? (alist-ref 'keep-going prev-step-params) 'yes))
		    (equal? (alist-ref 'keep-going the-step-params) 'yes))
		(let* ((prev-step-params the-step-params) ;; need to snag this now
		       (stepname    (car ezstep))  ;; do stuff to run the step
                       (logpro-used (common:file-exists? (conc test-run-dir "/" stepname ".logpro")))
		       (stepinfo    (cadr ezstep))
		       (stepparts   (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo))
		       (stepparms   (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each 
		       (stepcmd     (list-ref stepparts 3))

  (let loop ((etime (+ (current-seconds) 5))) ;; give up in five seconds
    (if (> *http-requests-in-progress* 0)
	(if (> etime (current-seconds))
	    (begin
	      (thread-sleep! 0.05)
	      (loop etime))
	    (debug:print-error 0 *default-log-port* "requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections"))
	(close-all-connections!)))
	(close-idle-connections!)))
  (set! *http-connections-next-cleanup* (+ (current-seconds) 10))
  (mutex-unlock! *http-mutex*))

(define (http-transport:inc-requests-and-prep-to-close-all-connections)
  (mutex-lock! *http-mutex*)
  (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*)))

					     (list (cons 'key (or server-id   "thekey"))
						   (cons 'cmd cmd)
						   (cons 'params sparams))
					     read-string))
					  transport: 'http)
                                         0)) ;; added this speculatively
			      ;; Shouldn't this be a call to the managed call-all-connections stuff above?
			      (close-all-connections!)
			      (close-idle-connections!)
			      (mutex-unlock! *http-mutex*)
			      ))
	      (time-out     (lambda ()
			      (thread-sleep! 45)
			      (debug:print 0 *default-log-port* "WARNING: send-receive took more than 45 seconds!!")
			      #f))
	      (th1 (make-thread send-recieve "with-input-from-request"))

          (if (common:low-noise-print 120 "server continuing")
              (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
	      (let ((curr-time (current-seconds)))
		(handle-exceptions
		    exn
		    (debug:print 0 *default-log-port* "ERROR: Failed to change timestamp on log file " server-log-file ". Are you out of space on that disk? exn=" exn)
		  (if (not *server-overloaded*)
		      (change-file-times server-log-file curr-time curr-time)))))
		      (set-file-times! server-log-file curr-time curr-time)))))
          (loop 0 server-state bad-sync-count (current-milliseconds)))
         (else
          (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access))
          (http-transport:server-shutdown port)))))))

(define (http-transport:server-shutdown port)
  (begin

(include "dbi/dbi.scm")
(include "stml2/cookie.scm")
(include "stml2/stml2.scm")
(include "pkts/pkts.scm")
(include "csv-xml/csv-xml.scm")
(include "ducttape/ducttape-lib.scm")
(include "hostinfo/hostinfo.scm")
(include "adjutant.scm")

;; (include "call-with-environment-variables/call-with-environment-variables.scm")

(module megatest-main
	*

	(import scheme

		
		(prefix sqlite3 sqlite3:)
		(prefix base64 base64:)
		address-info
		csv-abnf
		directory-utils
		fmt
		json
		matchable
		md5
		message-digest
		queues
		regex
		regex-case
		sql-de-lite
		stack
		typed-records
		s11n
		sparse-vectors
		sxml-serializer
		sxml-modifications
		system-information
		z3
		spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing

		
		srfi-1
		srfi-4
		srfi-18
		srfi-13
		srfi-98
		srfi-69

		;; local modules
		mutils
		csv-xml
		ducttape-lib
		hostinfo
		adjutant
		)
	
;; (include "common.scm")
(include "megatest-version.scm")

;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)

;; (use sparse-vectors)
;; 
;; (require-library mutils)

;; copied from egg call-with-environment-variables
;;
(define (call-with-environment-variables variables thunk)
  #;@("Sets up environment variable via dynamic-wind which are taken down after thunk."
    (variables "An alist of the form {{'((\"var\" . \"value\") ...)}}")
    (thunk "The thunk to execute with a modified environment"))
  ;; @("Sets up environment variable via dynamic-wind which are taken down after thunk."
  ;;   (variables "An alist of the form {{'((\"var\" . \"value\") ...)}}")
  ;;   (thunk "The thunk to execute with a modified environment"))
  (let ((pre-existing-variables
         (map (lambda (var-value)
                (let ((var (car var-value)))
                  (cons var (get-environment-variable var))))
              variables)))
    (dynamic-wind
        (lambda () (void))

			 (debug:print 0 *default-log-port* "WARNING: log file " logpath-in " path too long, converted to " newlogf)
			 newlogf)
		       logpath-in)))
     (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)
        (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath-in)
        (define *didsomething* #t)  
        (exit 1))))

;; this segment will run launch:setup only if -log is not set. This is fairly safe as servers are not
;; manually started and thus should never be started in a non-megatest area. Thus no need to handle situation
;; where (launch:setup) returns #f?
;;

;; == duplicated == 		     user
;; == duplicated == 		     args:arg-hash))))

;;======================================================================
;; Rollup into a run
;;======================================================================

(if (args:get-arg "-rollup")
    (general-run-call 
     "-rollup" 
     "rollup tests" 
     (lambda (target runname keys keyvals)
       (runs:rollup-run keys
			keyvals
			(or (args:get-arg "-runname")(args:get-arg ":runname") )
			user))))
;; (if (args:get-arg "-rollup")
;;     (general-run-call 
;;      "-rollup" 
;;      "rollup tests" 
;;      (lambda (target runname keys keyvals)
;;        (runs:rollup-run keys
;; 			keyvals
;; 			(or (args:get-arg "-runname")(args:get-arg ":runname") )
;; 			user))))

;;======================================================================
;; Lock or unlock a run
;;======================================================================

(if (or (args:get-arg "-lock")(args:get-arg "-unlock"))
    (general-run-call 

(if (args:get-arg "-mark-incompletes")
    (begin
      (if (not (launch:setup))
	  (begin
	    (debug:print 0 *default-log-port* "Failed to setup, exiting")
	    (exit 1)))
      (open-run-close db:find-and-mark-incomplete #f)
      (rmt:find-and-mark-incomplete #f)
      (set! *didsomething* #t)))

;;======================================================================
;; Update the tests meta data from the testconfig files
;;======================================================================

(if (args:get-arg "-update-meta")

	       (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #f run-patt target-patt)) ;; update this function
	      (close-output-port oup)
					; (set! page (+ 1 page))
	      (if (> total-runs (* (+ 1 page) pg-size))
		  (loop (+ 1  page)))))
	  (common:simple-file-release-lock lockfile))
	(begin
	  (debug-print 0 *default-log-port* "Failed to get lock on file outf, lockfile: " lockfile) #f))))
	  (debug:print 0 *default-log-port* "Failed to get lock on file outf, lockfile: " lockfile) #f))))


(define (tests:readlines filename)
  (call-with-input-file filename
    (lambda (p)
      (let loop ((line (read-line p))
                 (result '()))