Megatest

# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)'
# rm <files>.o ; make install CSCOPTS='-profile' ; ... ;  chicken-profile | less
SHELL=/bin/bash
PREFIX=$(PWD)
CSCOPTS=
INSTALL=install
SRCFILES = common.scm items.scm launch.scm \
   ods.scm runconfig.scm server.scm configf.scm \
   db.scm keys.scm margs.scm megatest-version.scm \
   process.scm runs.scm tasks.scm tests.scm genexample.scm \
   http-transport.scm filedb.scm tdb.scm \
   client.scm mt.scm \
   ezsteps.scm lock-queue.scm sdb.scm \
   rmt.scm api.scm subrun.scm \
   portlogger.scm archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm


# module source files
MSRCFILES = ftail.scm db.scm common.scm

# mtest module source files actually used by mtest building
MTMSRCFILES = ftail.scm

# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \
spiffy-directory-listing ssax sxml-serializer sxml-modifications iup canvas-draw sqlite3

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

OFILES   = $(SRCFILES:%.scm=%.o)
GOFILES  = $(GUISRCF:%.scm=%.o)

MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o))
MTMOFILES =  $(addprefix mofiles/,$(MTMSRCFILES:%.scm=%.o))

mofiles/%.o : src/%.scm
	mkdir -p mofiles
	cd mofiles;csc $(CSCOPTS) -J -c ../src/$*.scm -o $*.o

ADTLSCR=mt_laststep mt_runstep mt_ezstep
HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR))
DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR))
MTESTHASH=$(shell fossil info|grep checkout:| awk '{print $$2}')

CSIPATH=$(shell which csi)
CKPATH=$(shell dirname $(shell dirname $(CSIPATH)))
# ARCHSTR=$(shell uname -m)_$(shell uname -r)
# BASH_MACHTYPE=$(shell bash -c "echo \$$MACHTYPE")
# ARCHSTR=$(BASH_MACHTYPE)_$(shell lsb_release -sr)
ARCHSTR=$(shell if [[ -e /usr/bin/sw_vers ]]; then /usr/bin/sw_vers -productVersion; else lsb_release -sr; fi)
# ARCHSTR=$(shell bash -c "echo \$$MACHTYPE")

PNGFILES = $(shell cd docs/manual;ls *png)

#all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard
all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut

mtest: $(OFILES) readline-fix.scm megatest.scm $(MTMOFILES) megatest-fossil-hash.scm
	cp mofiles/ftail.import.scm .
	csc $(CSCOPTS) $(OFILES) $(MTMOFILES) megatest.scm -o mtest


dboard : $(OFILES) $(GOFILES) dashboard.scm $(MTMOFILES)
	csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MTMOFILES) -o dboard

ndboard : newdashboard.scm $(OFILES) $(GOFILES)
	csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard

mtut: $(OFILES) megatest-fossil-hash.scm mtut.scm $(MOFILES)
	cd mofiles;csc $(CSCOPTS) -I .. $(addprefix ../,$(OFILES)) ../mtut.scm -o mtut
	cp mofiles/mtut .

TCMTOBJS = \
	api.o \
	archive.o \
	cgisetup/models/pgdb.o \
	client.o \
	common.o \

# $(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm
#	csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl

# Special dependencies for the includes
tests.o db.o launch.o runs.o dashboard-tests.o dashboard-context-menu.o dashboard-guimonitor.o dashboard-main.o monitor.o dashboard.o  \
archive.o : db_records.scm
tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o  : run_records.scm
db.o ezsteps.o keys.o launch.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm common.o
tests.o tasks.o dashboard-tasks.o : task_records.scm
runs.o : test_records.scm
# megatest.o : megatest-fossil-hash.scm
rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm
common_records.scm : altdb.scm
vg.o dashboard.o : vg_records.scm
dcommon.o : run_records.scm
mofiles/db.o : mofiles/common.o

# Temporary while transitioning to new routine
# runs.o : run-tests-queue-classic.scm  run-tests-queue-new.scm

megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm
	echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new
	if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi

	mkdir -p ext-tests
	cd ext-tests;fossil open --nested $(MTQA_FOSSIL)

$(MTQA_FOSSIL) :
	fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL)

clean : 
	rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o

#======================================================================
# Make the records files
#======================================================================

# vg_records.scm : records.sh
#	./records.sh

	csc -deploy $(CSCOPTS) $(OFILES) megatest.scm -o deploytarg
	mv deploytarg/deploytarg deploytarg/mtest

deploytarg/dboard :  $(OFILES) $(GOFILES) dashboard.scm deploytarg/apropos.so
	csc -deploy $(OFILES) $(GOFILES) dashboard.scm -o deploytarg
	mv deploytarg/deploytarg deploytarg/dboard

# DATASHAREO=configf.o common.o process.o tree.o dcommon.o margs.o launch.o gutils.o db.o synchash.o server.o \
#            megatest-version.o tdb.o ods.o mt.o keys.o
datashare-testing/sd : datashare.scm $(OFILES)
	csc $(CSCOPTS) datashare.scm $(OFILES) -o datashare-testing/sd

datashare-testing/sdat: sharedat.scm $(OFILES)
	csc $(CSCOPTS) sharedat.scm $(OFILES) -o datashare-testing/sdat

sd : datashare-testing/sd

#!/bin/bash 

# This file is part of Megatest.
# 
#     Megatest is free software: you can redistribute it and/or modify
#     it under the terms of the GNU General Public License as published by
#     the Free Software Foundation, either version 3 of the License, or
#     (at your option) any later version.
# 
#     Megatest is distributed in the hope that it will be useful,
#     but WITHOUT ANY WARRANTY; without even the implied warranty of
#     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#     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/>.

if [[ $SLEEPRUNNER == "" ]];then
SLEEPRUNNER=0
fi
  
echo "nbfake $@ &> /dev/null" | at now + $SLEEPRUNNER minutes &> /dev/null

(declare (uses tdb))
(declare (uses mt))
(declare (uses api))
(declare (uses tasks)) ;; only used for debugging.
(declare (uses env))
(declare (uses diff-report))
(declare (uses ftail))
(import ftail)

(define *db* #f) ;; this is only for the repl, do not use in general!!!!

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

(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
     (prefix dbi dbi:)
     nanomsg)

(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
(declare (uses configf))
(declare (uses db)) ;; WARNING: This is NOT the db from megatest/db.scm, is it src/db.scm

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

(require-library stml)

(import (prefix db db:))


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

;======================================================================
;; Copyright 2006-2016, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     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/>.
;;
;;======================================================================

;; NOTE: This is the db module, long term it will replace db.scm.
;; WARN: This module conflicts with db.scm as it uses sql-de-lite

(declare (unit common))

(module common
        (
         get-create-writeable-dir
         print-error
         print-info
         log-event
         debug-setup
         debug-mode
         check-verbosity
         calc-verbosity
         )

(import scheme chicken data-structures extras posix ports)
(use (prefix sql-de-lite sql:) posix typed-records format srfi-1 srfi-69)

(defstruct ctrldat
  (port      (current-error-port))
  (verbosity 1)
  (vcache    (make-hash-table))
  (logging   #f) ;; keep the flag and the db handle separate to enable overriding
  (logdb     #f) ;; might need to make this a stack of handles for threaded access
  (toppath   #f) ;; 
  )

(define *log* (make-ctrldat))

;; this was cached based on results from profiling but it turned out the profiling
;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
;; in for now but can probably take it out later.
;;
(define (calc-verbosity vstr args)
  (or (hash-table-ref/default (ctrldat-vcache *log*) vstr #f)
      (let ((res (cond
                  ((number? vstr) vstr)
                  ((not (string?  vstr))   1)
                  ;; ((string-match  "^\\s*$" vstr) 1)
                  (vstr           (let ((debugvals  (filter number? (map string->number (string-split vstr ",")))))
                                    (cond
                                     ((> (length debugvals) 1) debugvals)
                                     ((> (length debugvals) 0)(car debugvals))
                                     (else 1))))
                  ((hash-table-exists? args "-v")   2)
                  ((hash-table-exists? args "-q")    0)
                  (else                   1))))
        (hash-table-set! (ctrldat-vcache *log*) vstr res)
        res)))

;; check verbosity, #t is ok
(define (check-verbosity verbosity vstr)
  (if (not (or (number? verbosity)
	       (list?   verbosity)))
      (begin
	(print "ERROR: Invalid debug value \"" vstr "\"")
	#f)
      #t))

(define (debug-mode n)
  (let* ((verbosity (ctrldat-verbosity *log*)))
    (cond
     ((and (number? verbosity)   ;; number number
           (number? n))
      (<= n verbosity))
     ((and (list? verbosity)     ;; list   number
           (number? n))
      (member n verbosity))
     ((and (list? verbosity)     ;; list   list
           (list? n))
      (not (null? (lset-intersection! eq? verbosity n))))
     ((and (number? verbosity)
           (list? n))
      (member verbosity n)))))

(define (debug-setup args)
  (let* ((debugstr  (or (hash-table-ref/default args "-debug" #f)
                        (get-environment-variable "MT_DEBUG_MODE")))
         (verbosity (calc-verbosity debugstr args)))
    ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
    (if (not (check-verbosity verbosity debugstr))
        (set! verbosity 1))
    (ctrldat-verbosity-set! *log* verbosity)
    (if (or (hash-table-exists? args "-debug")
	    (not (get-environment-variable "MT_DEBUG_MODE")))
	(setenv "MT_DEBUG_MODE" (if (list? verbosity)
				    (string-intersperse (map conc verbosity) ",")
				    (conc verbosity))))))
  
(define (debug-print n e . params)
  (if (debug-mode n)
      (with-output-to-port (or e (current-error-port))
	(lambda ()
	  (if (ctrldat-logging *log*)
	      (log-event (apply conc params))
	      (apply print params)
	      )))))

;; ;; Brandon's debug printer shortcut (indulge me :)
;; (define *BB-process-starttime* (current-milliseconds))
;; (define (BB> . in-args)
;;   (let* ((stack (get-call-chain))
;;          (location "??"))
;;     (for-each
;;      (lambda (frame)
;;        (let* ((this-loc (vector-ref frame 0))
;;               (temp     (string-split (->string this-loc) " "))
;;               (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???")))
;;          (if (equal? this-func "BB>")
;;              (set! location this-loc))))
;;      stack)
;;     (let* ((color-on "\x1b[1m")
;;            (color-off "\x1b[0m")
;;            (dp-args
;;             (append
;;              (list 0 *default-log-port*
;;                    (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off "   ")  )
;;              in-args)))
;;       (apply debug:print dp-args))))
;; 
;; (define *BBpp_custom_expanders_list* (make-hash-table))
;; 
;; 
;; 
;; ;; register hash tables with BBpp.
;; (hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE:
;;                  (cons hash-table? hash-table->alist))
;; 
;; ;; test name converter
;; (define (BBpp_custom_converter arg)
;;   (let ((res #f))
;;     (for-each
;;      (lambda (custom-type-name)
;;        (let* ((custom-type-info      (hash-table-ref *BBpp_custom_expanders_list* custom-type-name))
;;               (custom-type-test      (car custom-type-info))
;;               (custom-type-converter (cdr custom-type-info)))
;;          (when (and (not res) (custom-type-test arg))
;;            (set! res (custom-type-converter arg)))))
;;      (hash-table-keys *BBpp_custom_expanders_list*))
;;     (if res (BBpp_ res) arg)))
;; 
;; (define (BBpp_ arg)
;;   (cond
;;    ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg)))
;;    ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg)))
;;    ((hash-table? arg)
;;     (let ((al (hash-table->alist arg)))
;;       (BBpp_ (cons HASH_TABLE: al))))
;;    ((null? arg) '())
;;    ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
;;    ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
;;    (else (BBpp_custom_converter arg))))
;; 
;; ;; Brandon's pretty printer.  It expands hashes and custom types in addition to regular pp
;; (define (BBpp arg)
;;   (pp (BBpp_ arg)))
;; 
;; ;(use define-macro)
;; (define-syntax inspect
;;   (syntax-rules ()
;;     [(_ x)
;;     ;; (with-output-to-port (current-error-port)
;;        (printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x))))
;;      ;;  )
;;      ]
;;     [(_ x y ...) (begin (inspect x) (inspect y ...))]))

(define (print-error n e . params)
  ;; normal print
  (if (debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  (if (ctrldat-logging *log*)
	      (log-event (apply conc params))
	      ;; (apply print "pid:" (current-process-id) " " params)
	      (apply print "ERROR: " params)
	      ))))
  ;; pass important messages to stderr
  (if (and (eq? n 0)(not (eq? e (current-error-port)))) 
      (with-output-to-port (current-error-port)
	(lambda ()
	  (apply print "ERROR: " params)
	  ))))

(define (print-info n e . params)
  (if (debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  (if (ctrldat-logging *log*)
	      (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params))))
		(log-event res))
	      (apply print "INFO: (" n ") " params) ;; res)
	      )))))

;; if a value is printable (i.e. string or number) return the value
;; else return an empty string
(define-inline (printable val)
  (if (or (number? val)(string? val)) val ""))

;;======================================================================
;; L O G G I N G    D B 
;;======================================================================

(define (open-logging-db toppath)
  (let* ((dbpath    (conc (if toppath (conc toppath "/") "") "logging.db")) ;; fname)
	 (dbexists  (file-exists? dbpath))
	 (db        (sql:open-database dbpath))
	 (handler   (sql:busy-timeout 136000))) ;; remove argument to override
    (sql:set-busy-handler! db handler)
    (if (not dbexists)
        (sql:exec (sql:sql db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);")))
    (sql:exec (sql:sql db "PRAGMA synchronous = 0;"))
    db))

(define (log-local-event toppath . loglst)
  (let ((logline (apply conc loglst)))
    (log-event logline)))

(define (log-event toppath logline)
  (let ((db (open-logging-db toppath)))
    (sql:exec
     (sql:sql db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);")
     logline
     (current-directory)
     (string-intersperse (argv) " ")
     (current-process-id))
    logline))

;;======================================================================
;; paths and directories
;;======================================================================

;; return first path that can be created or already exists and is writable
;;
(define (get-create-writeable-dir dirs)
  (if (null? dirs)
      #f
      (let loop ((hed (car dirs))
		 (tal (cdr dirs)))
	(let ((res (or (and (directory? hed)
			    (file-write-access? hed)
			    hed)
		       (handle-exceptions
			   exn
			   (begin
			     ;; (debug:print-info 0 *default-log-port* "could not create " hed ", this might cause problems down the road.")
                             (print "INFO: could not create " hed ", this might cause problems down the road.")
			     #f)
			(create-directory hed #t)))))
	  (if (and (string? res)
		   (directory? res))
	      res
	      (if (null? tal)
		  #f
		  (loop (car tal)(cdr tal))))))))

(define old-file-exists? file-exists?)

(define (file-exists? path-string)
  ;; this avoids stack dumps. NOTE: The issues that triggered this approach might have been fixed TODO: test and remove if possible
  ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg:  system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q...
  (handle-exceptions
   exn
   #f
   (file-exists? path-string)))

)

;======================================================================
;; Copyright 2006-2016, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     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/>.
;;
;;======================================================================

;; NOTE: This is the db module, long term it will replace db.scm.
;; WARN: This module conflicts with db.scm as it uses sql-de-lite

(declare (unit db))
(declare (uses common))

(module db
        (
         get-db-tmp-area
         )

(import scheme chicken data-structures extras (prefix common common:))
(use (prefix sql-de-lite sql) posix typed-records)

(define *default-log-port* (current-error-port))

;;======================================================================
;; Database access
;;======================================================================


;;======================================================================
;;  R E C O R D S
;;======================================================================

;; areas
;;    run.db
;;    runs => 1.db, 2.db ...

;; each db entry is a pair ( db . dbfilepath )
;; I propose this record evolves into the area record
;;
(defstruct dbr:dbstruct 
  (tmpdb       #f)
  (dbstack     #f) ;; stack for tmp db handles, do not initialize with a stack
  (mtdb        #f)
  (refndb      #f)
  (homehost    #f) ;; not used yet
  (on-homehost #f) ;; not used yet
  (read-only   #f)
  )                ;; goal is to converge on one struct for an area but for now it is too confusing
  

;; record for keeping state,status and count for doing roll-ups in
;; iterated tests
;;
(defstruct dbr:counts
  (state #f)
  (status #f)
  (count  0)) 

;;======================================================================
;; SQLITE3 HELPERS
;;======================================================================


(define (general-sql-de-lite-error-dump exn stmt . params)
  (let ((err-status ((condition-property-accessor 'sql-de-lite 'status #f) exn))) ;; RADT ... how does this work?
    ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn)
    (print "err-status: " err-status)
    (common:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn))
    (print-call-chain (current-error-port))))

;;======================================================================
;; Manage the /tmp/ db mirror area
;;======================================================================

(define (get-db-tmp-area area-path area-name)
  (let ((dbdir (conc "/tmp/" (current-user-name)
                     "/megatest_localdb/"
                     area-name "/"
                     (string-translate area-path "/" "."))))
    (if area-path ;; common:get-create-writeable-dir
        (handle-exceptions
         exn
         (begin
           (common:print-error 0 *default-log-port* "Couldn't create path to " dbdir)
           (exit 1))
         (let ((dbpath (common:get-create-writeable-dir
                        (list dbdir)))) ;;  #t))))
           dbpath))
        #f)))


)