Megatest

# module source files
# MSRCFILES = 
# ftail.scm rmtmod.scm commonmod.scm removed
MSRCFILES = autoload.scm dbi.scm ducttape-lib.scm pkts.scm stml2.scm	\
            cookie.scm mutils.scm mtargs.scm apimod.scm commonmod.scm	\
            dbmod.scm rmtmod.scm debugprint.scm mtver.scm csv-xml.scm	\
            servermod.scm hostinfo.scm adjutant.scm

# commonmod.scm dbmod.scm adjutant.scm ulex.scm	\
#            rmtmod.scm apimod.scm

GUISRCF = dashboard-context-menu.scm dashboard-tests.scm		\
          dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm	\
          vg.scm

(define *already-seen-runconfig-info* #f)

(define *test-meta-updated* (make-hash-table))
(define *globalexitstatus*  0) ;; attempt to work around possible thread issues
(define *passnum*           0) ;; when running track calls to run-tests or similar
;; (define *alt-log-file* #f)  ;; used by -log
(define *common:denoise*    (make-hash-table)) ;; for low noise printing
(define *default-log-port*  (current-error-port))
(define *time-zero* (current-seconds)) ;; for the watchdog
(define *default-area-tag* "local")

;; DATABASE
(define *dbstruct-db*         #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this.
;; db stats
(define *db-stats*            (make-hash-table)) ;; hash of vectors < count duration-total >

;;  misc conversion, data manipulation functions
;;  testsuite and area utilites
;;
;;======================================================================

(include "megatest-fossil-hash.scm")





;; dot-locking egg seems not to work, using this for now
;; if lock is older than expire-time then remove it and try again
;; to get the lock
;;
(define (common:simple-file-lock fname #!key (expire-time 300))
  (let ((fmod-time (handle-exceptions
		       ext

     current-wwdate
     current-isodate
     *this-exe-dir*
     *this-exe-name*
     *this-exe-fullpath*
     )



















  (import scheme chicken.base chicken.port chicken.process chicken.io chicken.pathname chicken.process-context chicken.time chicken.process chicken.condition chicken.time.posix chicken.process-context.posix chicken.format chicken.file.posix)
  (import regex ansi-escape-sequences test srfi-1 chicken.irregex slice srfi-13 rfc3339)
  ;;scsh-process ;; dropping scsh-process, it was clobbering posix's process and process*
  ;;(import directory-utils uuid-lib filepath srfi-19 ) ; linenoise
  (import directory-utils filepath srfi-19 ) ; linenoise

    ;; plugs a hole in posix-extras in latter chicken versions
  (import pathname-expand chicken.file chicken.string)
  (define ##sys#expand-home-path pathname-expand)
  (define (realpath x) (print "Path: " x) (normalize-pathname  (pathname-expand (or x "/dev/null")) ))
  ;;(define (realpath x) (pathname-expand (or x "/dev/null")))



  ;; (include "mimetypes.scm") ; provides ext->mimetype
  ;; (include "workweekdate.scm")

  ;; gathered from macosx:
;;   cat /etc/apache2/mime.types | grep -v '^#' | perl -ne 'print "(\"$2\" . \"$1\")\n" if /(\S+)\s+(\S+)/' > mimetypes.scm
;; + manual manipulation

;; (require-library stml)
(define (http-transport:make-server-url hostport)
  (if (not hostport)
      #f
      (conc "http://" (car hostport) ":" (cadr hostport))))

(define *server-loop-heart-beat* (current-seconds))

;;======================================================================
;; S E R V E R
;; ======================================================================

;; Call this to start the actual server
;;

	  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

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")

(include "common.scm")
(include "megatest-fossil-hash.scm")

(include "configf.scm")
(include "margs.scm")
(include "process.scm")
(include "keys.scm")
(include "portlogger.scm")
(include "db.scm")

;;;      
;;;      ;; Added for csv stuff - will be removed
;;;      ;;
;;;      ;; (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"))
;;;        (let ((pre-existing-variables
;;;               (map (lambda (var-value)
;;;                      (let ((var (car var-value)))
;;;                        (cons var (get-environment-variable var))))
;;;                    variables)))
;;;          (dynamic-wind
;;;              (lambda () (void))
;;;              (lambda ()
;;;      ;;           (use posix)
;;;                (for-each (lambda (var-value)
;;;                            (setenv (car var-value) (cdr var-value)))
;;;                  variables)
;;;                (thunk))
;;;              (lambda ()
;;;                (for-each (lambda (var-value)
;;;                            (let ((var (car var-value))
;;;                                  (value (cdr var-value)))
;;;                              (if value
;;;                                  (setenv var value)
;;;                                  (unsetenv var))))
;;;                  pre-existing-variables)))))
;;;      
;;;      
;;;      
;;;      (define *usage-log-file* #f)    ;; put path to file for logging usage in this var in the ~/.megatestrc file
;;;      (define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file
;;;      
;;;      ;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file
;;;      ;;

;;;      ;;
;;;      (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
;;;        (if targ (setenv "MT_TARGET" targ)))
;;;      
;;;      ;; The watchdog is to keep an eye on things like db sync etc.
;;;      ;;
;;;      

;;;      ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
;;;      (define *watchdog* (make-thread
;;;      		    (lambda ()
;;;      		      (handle-exceptions
;;;      			  exn
;;;      			  (begin
;;;      			    (print-call-chain)
;;;      			    (print " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn))
;;;      			(common:watchdog)))
;;;      		    "Watchdog thread"))
;;;      
;;;      ;;(if (not (args:get-arg "-server"))
;;;      ;;    (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog
;;;      (let* ((no-watchdog-args
;;;             '("-list-runs"
;;;               "-testdata-csv"
;;;               "-list-servers"
;;;               "-server"

;;;                             targets))
;;;                  ((json)
;;;                   (json-write targets))
;;;                  (else
;;;                   (debug:print-error 0 *default-log-port* "dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets")))
;;;                (set! *didsomething* #t))))
;;;      

;;;      ;; cache the runconfigs in $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME/.runconfig
;;;      ;;
;;;      (define (full-runconfigs-read)
;;;      ;; in the envprocessing branch the below code replaces the further below code
;;;      ;;  (if (eq? *configstatus* 'fulldata)
;;;      ;;      *runconfigdat*
;;;      ;;      (begin
;;;      ;;	(launch:setup)
;;;      ;;	*runconfigdat*)))
;;;      
;;;        (let* ((rundir (if (and (getenv "MT_LINKTREE")(getenv "MT_TARGET")(getenv "MT_RUNNAME"))
;;;      		     (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME"))
;;;      		     #f))
;;;      	 (cfgf   (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f)))
;;;          (if (and cfgf
;;;      	     (common:file-exists? cfgf)
;;;      	     (file-writable? cfgf)
;;;      	     (common:use-cache?))
;;;      	(configf:read-alist cfgf)
;;;      	(let* ((keys   (rmt:get-keys))
;;;      	       (target (common:args-get-target))
;;;      	       (key-vals (if target (keys:target->keyval keys target) #f))
;;;      	       (sections (if target (list "default" target) #f))
;;;      	       (data     (begin
;;;      			   (setenv "MT_RUN_AREA_HOME" *toppath*)
;;;      			   (if key-vals
;;;      			       (for-each (lambda (kt)
;;;      					   (setenv (car kt) (cadr kt)))
;;;      					 key-vals))
;;;      			   ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections))))
;;;                                 (runconfig:read (conc *toppath* "/runconfigs.config") target #f))))
;;;      	  (if (and rundir ;; have all needed variabless
;;;      		   (directory-exists? rundir)
;;;      		   (file-writable? rundir))
;;;      	      (begin
;;;                      (if (not (common:in-running-test?))
;;;                          (configf:write-alist data cfgf))
;;;      		;; force re-read of megatest.config - this resolves circular references between megatest.config
;;;      		(launch:setup force-reread: #t)
;;;      		;; (launch:cache-config) ;; there are two independent config cache locations, turning this one off for now. MRW.
;;;      		)) ;; we can safely cache megatest.config since we have a valid runconfig
;;;      	  data))))
;;;      
;;;      (if (args:get-arg "-show-runconfig")
;;;          (let ((tl (launch:setup)))
;;;            (push-directory *toppath*)
;;;            (let ((data (full-runconfigs-read)))
;;;      	;; keep this one local
;;;      	(cond

         (duty-cycle   (configf:lookup-number *configdat* "server" "sync-duty-cycle" default: default-duty-cycle))
         (last-sync-seconds 10) ;; we will adjust this to a measurement and delay last-sync-seconds * (1 - duty-cycle)
         (calculate-off-time (lambda (work-duration duty-cycle)
                                  (* (/ (- 1 duty-cycle) duty-cycle) last-sync-seconds)))
         (off-time min-intersync-delay) ;; adjusted in closure below.
         (do-a-sync
          (lambda ()
            (BB> "Start do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync)
            (let* ((finalres
                    (let retry-loop ((num-tries 0))
                         (if (common:simple-file-lock lockfile)
	                     (begin
                               (cond
                                ((not (or fork-to-background persist-until-sync))
                                 (debug:print 0 *default-log-port* "INFO: syncer thread sleeping for max of (server.minimum-intersync-delay="min-intersync-delay

                                        (else
                                         (system (conc "/bin/cp "sync-log" "sync-log".fail"))
                                         (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Sync failed. See log at "sync-log".fail")
                                         (if (file-exists? (conc mtdbfile ".backup"))
                                             (system (conc "/bin/cp "mtdbfile ".backup " mtdbfile)))
                                         #f))))
                                 (common:simple-file-release-lock lockfile)
                                 (BB> "released lockfile: " lockfile)
                                 (when (common:file-exists? lockfile)
                                   (BB> "DID NOT ACTUALLY RELEASE LOCKFILE"))
                                 res2) ;; end let
                               );; end begin
                             ;; else
                             (cond
                              (persist-until-sync
                               (thread-sleep! 1)
                               (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; we're in a fork-to-background so we need to succeed.  Let's wait a jiffy and and try again. num-tries="num-tries" (waiting for lockfile="lockfile" to disappear)")
                               (retry-loop (add1 num-tries)))
                              (else
                               (thread-sleep! (max off-time (+ last-sync-seconds min-intersync-delay)))
                               (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; not syncing.")
                               'parallel-sync-in-progress))
                             ) ;; end if got lockfile
                         )
                    ))
              (BB> "End do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync" and result="finalres)
              finalres)
            ) ;; end lambda
          ))
    do-a-sync))

(define (server:writable-watchdog-bruteforce dbstruct)
  (thread-sleep! 1) ;; delay for startup

	)

(define (server:make-server-url hostport)
  (if (not hostport)
      #f
      (conc "http://" (car hostport) ":" (cadr hostport))))

(define  *server-loop-heart-beat* (current-seconds))

(define (server:get-logs-list area-path)
  (let* ((server-logs-cmd  (conc "grep -iL exiting " area-path "/logs/server-*-*.log"))
	 (server-logs   (string-split (string-chomp (with-input-from-pipe server-logs-cmd read-string)))))
    server-logs))
  

)