Megatest

           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 = adjutant.scm mutils.scm mttop.scm
MSRCFILES = adjutant.scm mutils.scm mttop.scm ulex.scm dbmod.scm rmtmod.scm commonmod.scm
# ftail.scm rmtmod.scm commonmod.scm removed
# MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm	\
#             mtargs.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	\

$(PREFIX)/share/db/mt-pg.sql : mt-pg.sql
	mkdir -p $(PREFIX)/share/db
	$(INSTALL) mt-pg.sql $(PREFIX)/share/db/mt-pg.sql

# Special dependencies for the includes
$(MOFILE) $(MOIMPFILES) : megatest-fossil-hash.scm

#======================================================================
# Other deps
#======================================================================

# common.o : mofiles/commonmod.o megatest-fossil-hash.scm

# commonmod.o dashboard.o megatest.o tcmt.o apimod.o : megatest-fossil-hash.scm

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 megatest.o : db_records.scm megatest-fossil-hash.scm
mofiles/ulex.o : ulex/ulex.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 megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm

tests.o tasks.o dashboard-tasks.o : task_records.scm

	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
(import commonmod)
(import (prefix ulex ulex:))


(define (api:execute-requests params)
(define (execute-requests params)
  #f)

)

(declare (uses diff-report))
(declare (uses mutils))
(declare (uses adjutant))
(import adjutant)

(declare (uses mttop))
(import mttop)
(declare (uses ulex))
(import ulex)

(declare (uses rmtmod))
(import (prefix rmtmod rmtmod:))

(declare (uses ulex))
(import (prefix ulex ulex:))

;; (declare (uses ftail))
;; (import ftail)

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

(include "common_records.scm")

test:
	 env CHICKEN_REPOSITORY=../../../megatest/tmpinstall/eggs/lib/chicken/7 csi -s tests/run.scm

(
; Your egg's license:
(license "LGPL")

; Pick one from the list of categories (see below) for your egg and enter it
; here.
(category misc)

; A list of eggs mpeg3 depends on.  If none, you can omit this declaration
; altogether. If you are making an egg for chicken 3 and you need to use
; procedures from the `files' unit, be sure to include the `files' egg in the
; `needs' section (chicken versions < 3.4.0 don't provide the `files' unit).
; `depends' is an alias to `needs'.
(needs srfi-1 srfi-69 regex regex-case directory-utils extras srfi-13 posix typed-records)

; A list of eggs required for TESTING ONLY.  See the `Tests' section.
(test-depends test)

(author "Matt Welland")
(synopsis "Megatest config file (ini-space format) with many enhancements."))

;;======================================================================
;; Copyright 2006-2018, 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 configf module, long term it will replace configf.scm.

(module mtconfigf
        (
	 set-debug-printers
	 lazy-convert
	 assoc-safe-add
	 section-var-set!
	 safe-file-exists?
	 read-link-f
	 nice-path
	 eval-string-in-environment
	 safe-setenv
	 with-env-vars
	 cmd-run->list
	 port->list
	 configf:system
	 process-line
	 shell
	 configf:read-line
	 cfgdat->env-alist
	 calc-allow-system
	 apply-wildcards
	 val->alist
	 section->val-alist
	 read-config
	 find-config
	 find-and-read-config
	 lookup
	 var-is?
	 lookup-number
	 section-vars
	 get-section
	 set-section-var
	 compress-multi-lines
	 expand-multi-lines
	 file->list
	 write-config
	 write-merge-config
	 read-refdb
	 map-all-hier-alist
	 config->alist
	 alist->config
	 read-alist
	 write-alist
	 config->ini
	 ;;set-verbosity
         add-eval-string
	 get-eval-string
         squelch-debug-prints
	 ;; misc
	 realpath
	 find-chicken-lib
         )

(import scheme chicken data-structures extras ports files)
(use posix typed-records srfi-18 pathname-expand posix-extras)
(use regex regex-case srfi-69 srfi-1 directory-utils extras srfi-13 )
(use srfi-69)
(import posix)

;; stub debug printers overridden by set-debug-printers
(define (debug:print n e . args)
  (apply print args))
(define (debug:print-info n e . args)
  (apply print "INFO: " args))
(define (debug:print-error n e . args)
  (apply print "ERROR: " args))

;;(import (prefix mtdebug debug:))
;;(define args:any? args:any-defined?) ;; cannot name it any? in mtargs module


;; FROM common.scm
;;
;; this plugs a hole in posix-extras in recent chicken versions > 4.9)
(let-values (( (chicken-release-number chicken-major-version)
               (apply values
                      (map string->number
                           (take
                            (string-split (chicken-version) ".")
                            2)))))
  (if (or (> chicken-release-number 4)
	  (and (eq? 4 chicken-release-number) (> chicken-major-version 9)))
      (define ##sys#expand-home-path pathname-expand)))


 ;;(define (set-verbosity v)(debug:set-verbosity v))

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

 (define (debug:print-error n . args) ;;; n available to end-users but ignored for
   ;; default provided function
  (with-output-to-port (current-error-port)
    (lambda ()
      (apply print "ERROR: "args))))

(define (set-debug-printers normal-fn info-fn error-fn default-port)
  (if error-fn  (set! debug:print-error error-fn))
  (if info-fn   (set! debug:print-info  info-fn))
  (if normal-fn (set! debug:print       normal-fn))
  (if default-port (set! *default-log-port* default-port)))

(define (squelch-debug-prints)
  (let ((noop (lambda x #f)))
    (set! debug:print noop)
    (set! debug:print-info noop)))


;; if it looks like a number -> convert it to a number, else return it
;;
(define (lazy-convert inval)
  (let* ((as-num (if (string? inval)(string->number inval) #f)))
    (or as-num inval)))


(define *eval-string* "")
(define (add-eval-string str)
  (if (not (string-contains *eval-string* str))
      (set! *eval-string* (conc *eval-string* " " str))))
(define (get-eval-string) *eval-string*)

;; Moved to common
;;
;; return list (path fullpath configname)
(define (find-config configname #!key (toppath #f))
  (if toppath
      (let ((cfname (conc toppath "/" configname)))
	(if (safe-file-exists? cfname)
	    (list toppath cfname configname)
	    (list #f      #f     #f)))
      (let* ((cwd (string-split (current-directory) "/")))
	(let loop ((dir cwd))
	  (let* ((path     (conc "/" (string-intersperse dir "/")))
		 (fullpath (conc path "/" configname)))
	    (if (safe-file-exists? fullpath)
		(list path fullpath configname)
		(let ((remcwd (take dir (- (length dir) 1))))
		  (if (null? remcwd)
		      (list #f #f #f) ;;  #f #f) 
		  (loop remcwd)))))))))

(define (assoc-safe-add alist key val #!key (metadata #f))
  (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist)))
    (append newalist (list (if metadata
			       (list key val metadata)
			       (list key val))))))

(define (section-var-set! cfgdat section-name var value #!key (metadata #f))
  (hash-table-set! cfgdat section-name
		   (assoc-safe-add
		    (hash-table-ref/default cfgdat section-name '())
		    var value metadata: metadata)))
;;======================================================================
;; Environment handling stuff
;;======================================================================

(define (safe-file-exists? path)
  (handle-exceptions exn #f (file-exists? path)))

(define (read-link-f path)
  (handle-exceptions
      exn
      (begin
	(debug:print-error 0 *default-log-port* "command \"/bin/readlink -f " path "\" failed.")
	path) ;; just give up
    (with-input-from-pipe
	(conc "/bin/readlink -f " path)
      (lambda ()
	(read-line)))))

;; return a nice clean pathname made absolute
(define (nice-path dir)
  (let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir)))
    (if match ;; using ~ for home?
	(nice-path (conc #;(read-link-f (cadr match))
		    (realpath (cadr match))
		    "/" (caddr match)))
	(normalize-pathname (if (absolute-pathname? dir)
				dir
				(conc (current-directory) "/" dir))))))

(define (eval-string-in-environment str)
  (handle-exceptions
   exn
   (begin
     (debug:print-error 0 *default-log-port* "problem evaluating \"" str "\" in the shell environment")
     #f)
   (let ((cmdres (cmd-run->list (conc "echo " str))))
     (if (null? cmdres) ""
	 (caar cmdres)))))

(define (safe-setenv key val)
  (if (substring-index ":" key) ;; variables containing : are for internal use and cannot be environment variables.
      (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\"")
      (if (and (string? val)
	       (string? key))
	  (handle-exceptions
	      exn
	      (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)
	    (setenv key val))
	  (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val))))

;; accept an alist or hash table containing envvar/env value pairs (value of #f causes unset) 
;;   execute thunk in context of environment modified as per this list
;;   restore env to prior state then return value of eval'd thunk.
;;   ** this is not thread safe **
(define (with-env-vars delta-env-alist-or-hash-table thunk)
  (let* ((delta-env-alist (if (hash-table? delta-env-alist-or-hash-table)
                              (hash-table->alist delta-env-alist-or-hash-table)
                              delta-env-alist-or-hash-table))
         (restore-thunks
          (filter
           identity
           (map (lambda (env-pair)
                  (let* ((env-var     (car env-pair))
                         (new-val     (let ((tmp (cdr env-pair)))
                                        (if (list? tmp) (car tmp) tmp)))
                         (current-val (get-environment-variable env-var))
                         (restore-thunk
                          (cond
                           ((not current-val) (lambda () (unsetenv env-var)))
                           ((not (string? new-val)) #f)
                           ((eq? current-val new-val) #f)
                           (else 
                            (lambda () (setenv env-var current-val))))))
                    ;;(when (not (string? new-val))
                    ;;    (debug:print 0 *default-log-port* " PROBLEM: not a string: "new-val"\n from env-alist:\n"delta-env-alist)
                    ;;    (pp delta-env-alist)
                    ;;    (exit 1))
                        
                    
                    (cond
                     ((not new-val)  ;; modify env here
                      (unsetenv env-var))
                     ((string? new-val)
                      (setenv env-var new-val)))
                    restore-thunk))
                delta-env-alist))))
    (let ((rv (thunk)))
      (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state
      rv)))

(define (cmd-run->list cmd #!key (delta-env-alist-or-hash-table '()))
  (with-env-vars
   delta-env-alist-or-hash-table
   (lambda ()
     (let* ((fh (open-input-pipe cmd))
            (res (port->list fh))
            (status (close-input-pipe fh)))
       (list res status)))))
   
(define (port->list fh)
  (if (eof-object? fh) #f
      (let loop ((curr (read-line fh))
                 (result '()))
        (if (not (eof-object? curr))
            (loop (read-line fh)
                  (append result (list curr)))
            result))))

;;======================================================================
;; Make the regexp's needed globally available
;;======================================================================

(define configf:include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$"))
(define configf:script-rx  (regexp "^\\[scriptinc\\s+(\\S+)([^\\]]*)\\]\\s*$")) ;; include output from a script
(define configf:section-rx (regexp "^\\[(.*)\\]\\s*$"))
(define configf:blank-l-rx (regexp "^\\s*$"))
(define configf:key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$"))
(define configf:key-val-pr (regexp "^(\\S+)(\\s+(.*)|())$"))
(define configf:key-no-val (regexp "^(\\S+)(\\s*)$"))
(define configf:comment-rx (regexp "^\\s*#.*"))
(define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$"))
(define configf:settings   (regexp "^\\[configf:settings\\s+(\\S+)\\s+(\\S+)]\\s*$"))
(define configf:initstr-rx (regexp "^\\[configf:initstr\\s+(.*)\\]\\s*$"))

;; read a line and process any #{ ... } constructs

(define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget|scm|sh|rp|gv|g|mtrah)\\s+([^\\}\\{]*)\\}(.*)"))

(define (configf:system ht cmd)
  (system cmd)
  )

;; Lookup a value in runconfigs based on -reqtarg or -target
;; 
(define (runconfigs-get config var) ;; .dvars is a special bin for storing metadata such as target
  (let ((targ (lookup config ".dvars" "target"))) ;; (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
    (if targ
	(or (lookup config targ var)
	    (lookup config "default" var))
	(lookup config "default" var))))

(define (realpath x)
  (let ((currdir (current-directory)))
    (handle-exceptions
	exn
	(begin
	  (change-directory currdir)
	  x) ;; anything goes wrong - return given path
      (change-directory x)
      (let ((result (current-directory)))
	(change-directory currdir)
	result))))

;;  (resolve-pathname  (pathname-expand (or x "/dev/null")) ))

(define (common:get-this-exe-fullpath #!key (argv (argv)))
  (let* ((this-script
          (cond
           ((and (> (length argv) 2)
                 (string-match "^(.*/csi|csi)$" (car argv))
                 (string-match "^-(s|ss|sx|script)$" (cadr argv)))
            (caddr argv))
           (else (car argv))))
         (fullpath (realpath this-script)))
    fullpath))

;; (use trace)
;; (trace-call-sites #t)
;; (trace realpath common:get-this-exe-fullpath)

(define *common:this-exe-fullpath* (common:get-this-exe-fullpath))
(define *common:this-exe-dir*      (pathname-directory *common:this-exe-fullpath*))
(define *common:this-exe-name*     (pathname-strip-directory *common:this-exe-fullpath*))

(define (find-chicken-lib)
  (let* ((ckhome         (chicken-home))
	 (libpath-number (car (reverse (string-split  (repository-path) "/"))))
	 (libpath        (conc *common:this-exe-dir* "/../../eggs/lib/chicken/" libpath-number)))
    (if (and (not (get-environment-variable "CHICKEN_REPOSITORY"))
	     (directory-exists? libpath))
	(conc "(repository-path \""libpath"\") ")
	"")))
  
(define (process-line l ht allow-system #!key (linenum #f)(extend-eval ""))
  (let loop ((res l))
    (if (string? res)
	(let ((matchdat (string-search configf:var-expand-regex res)))
	  (if matchdat
	      (let* ((prestr  (list-ref matchdat 1))
		     (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv
		     (cmd     (list-ref matchdat 3))
		     (poststr (list-ref matchdat 4))
		     (result  #f)
		     (start-time (current-milliseconds))
		     (cmdsym  (string->symbol cmdtype))
		     (presnip (conc "(import posix)(import directory-utils)"
				    "(set! getenv get-environment-variable)"
                                    ))
		     (allsnip (conc "(import posix)(import directory-utils)"
				    "(set! getenv get-environment-variable)"
				    (find-chicken-lib)
                                    "(import (prefix mtconfigf configf:))"
				    "(import mtconfigf)"
                                    *eval-string*))
		     (fullcmd (case cmdsym
				((scheme scm) (conc "(lambda (ht)" allsnip "" cmd "))"))
				((system)     (conc "(lambda (ht)" allsnip "(configf:system ht \"" cmd "\"))"))
				((shell sh)   (conc "(lambda (ht)" allsnip "(string-translate (shell \""  cmd "\") \"\n\" \" \"))"))
				((realpath rp)(conc "(lambda (ht)" allsnip "(configf:nice-path \"" cmd "\"))"))
				((getenv gv)  (conc "(lambda (ht)(get-environment-variable \"" cmd "\"))"))
				((mtrah)      (conc "(lambda (ht)"
						    allsnip
                                                    "  (let ((extra \"" cmd "\"))"
						    "     (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\"))"
						    "        (if (string-null? extra) \"\" \"/\")"
						    "     extra)))"))
				((get g)   
				 (let* ((parts (string-split cmd))
					(sect  (car parts))
					(var   (cadr parts)))
				   (conc "(lambda (ht)(configf:lookup ht \"" sect "\" \"" var "\"))")))
				;;((runconfigs-get rget) (conc "(lambda (ht)" allsnip "(configf:runconfigs-get ht \"" cmd "\"))"))
                                ((runconfigs-get rget)
                                 (runconfigs-get ht cmd))
				(else "(lambda (ht)(print \"ERROR\") \"ERROR\")"))))

		(handle-exceptions
		    exn
		    (let ((arguments ((condition-property-accessor 'exn 'arguments) exn))
			  (message    ((condition-property-accessor 'exn 'message) exn))
			  (allstr     (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd)))
		      (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\"")
		      (debug:print 0 *default-log-port* " message: " message 
				   (if arguments
				       (conc "; " (string-intersperse (map conc arguments) ", "))
				       ""))
		      (debug:print 0 *default-log-port* "INFO: allstr is\n" allstr)
		      ;; (debug:print 0 *default-log-port* "exn=" (condition->list exn))
		      (set! result allstr))
		  (if (or allow-system
			  (not (member cmdtype '("system" "shell" "sh"))))
                      (if (member cmdsym '(runconfigs-get rget))
                          (begin
                            (set! result fullcmd)
                            fullcmd)
		          (with-input-from-string fullcmd
			    (lambda ()
			      (set! result ((eval (read)
						  ;;(module-environment 'mtconfigf)
						  ) ht)))))
		      (set! result (conc "#{(" cmdtype ") "  cmd "}"))))
		(case cmdsym
		  ((system shell scheme scm sh)
		   (let ((delta (- (current-milliseconds) start-time)))
		     (if (> delta 2000)
			 (debug:print-info 0 *default-log-port* "for line \"" l "\"\n command:  " cmd " took " (/ delta 1000) " seconds to run with output:\n   " result)
			 (debug:print-info 9 *default-log-port* "for line \"" l "\"\n command:  " cmd " took " (/ delta 1000) " seconds to run with output:\n   " result)))))
		(loop (conc prestr result poststr)))
	      res))
	res)))

;; Run a shell command and return the output as a string
(define (shell cmd)
  (let* ((output (cmd-run->list cmd))
	 (res    (car output))
	 (status (cadr output)))
    (if (equal? status 0)
	(let ((outres (string-intersperse 
		       res
		       "\n")))
	  (debug:print-info 4 *default-log-port* "shell result:\n" outres)
	  outres)
	(begin
	  (with-output-to-port (current-error-port)
	    (lambda ()
	      (print "ERROR: " cmd " returned bad exit code " status)))
	  ""))))

;; this was inline but I'm pretty sure that is a hold over from when it was *very* simple ...
;;
(define (configf:read-line p ht allow-processing settings #!key ....)
  (let loop ((inl (read-line p)))
    (let ((cont-line (and (string? inl)
			  (not (string-null? inl))
			  (equal? "\\" (string-take-right inl 1)))))
      (if cont-line ;; last character is \ 
	  (let ((nextl (read-line p)))
	    (if (not (eof-object? nextl))
		(loop (string-append (if cont-line 
					 (string-take inl (- (string-length inl) 1))
					 inl)
				     nextl))))
	  (let ((res (case allow-processing ;; if (and allow-processing 
		       ;;	   (not (eq? allow-processing 'return-string)))
		       ((#t #f)
			(process-line inl ht allow-processing))
		       ((return-string)
			inl)
		       (else
			(process-line inl ht allow-processing)))))
	    (if (string? res)
		(let* ((r1 (if (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "no") "no"))
			       (string-substitute "\\s+$" "" res)
			       res))
		       (r2 (if (not (equal? (hash-table-ref/default settings "line-end-comments" "no") "no"))
			      (string-substitute "\\s*#+[^\\{]*.*$" "" r1)
			      r1)))
		  r2)
		res))))))

(define (cfgdat->env-alist section cfgdat-ht allow-system)
  (filter
   (lambda (pair)
     (let* ((var (car pair))
            (val (cdr pair)))
       (cons var
             (cond
              ((and allow-system (procedure? val)) ;; if we decided to use something other than #t or #f for allow-system ('return-procs or 'return-string) , this may become problematic
               (val))
              ((procedure? val) #f)
              ((string? val) val)
              (else "#f")))))
   (append
    (hash-table-ref/default cfgdat-ht "default" '())
    (if (equal? section "default") '() (hash-table-ref/default cfgdat-ht section '())))))

(define (calc-allow-system allow-system section sections)
  (if sections
      (and (or (equal? "default" section)
	       (member section sections))
	   allow-system) ;; account for sections and return allow-system as it might be a symbol such as return-strings
      allow-system))
    
;; given a config hash and a section name, apply that section to all matching sections (using wildcard % or regex if /..../)
;; remove the section when done so that there is no downstream clobbering
;;
(define (apply-wildcards ht section-name)
  (if (hash-table-exists? ht section-name)
      (let* ((vars  (hash-table-ref ht section-name))
	     (rxstr (if (string-contains section-name "%")
			(string-substitute (regexp "%") ".*" section-name)
			(string-substitute (regexp "^/(.*)/$") "\\1" section-name)))
	     (rx    (regexp rxstr)))
	;; (print "\nsection-name: " section-name " rxstr: " rxstr)
        (for-each
         (lambda (section)
	   (if section
	       (let ((same-section (string=? section-name section))
		     (rx-match     (string-match rx section)))
		 ;; (print "section: " section " vars: " vars " same-section: " same-section " rx-match: " rx-match)
		 (if (and (not same-section) rx-match)
		     (for-each
		      (lambda (bundle)
			;; (print "bundle: " bundle)
			(let ((key  (car bundle))
			      (val  (cadr bundle))
			      (meta (if (> (length bundle) 2)(caddr bundle) #f)))
			  (hash-table-set! ht section (assoc-safe-add (hash-table-ref ht section) key val metadata: meta))))
		      vars)))))
         (hash-table-keys ht))))
  ht)

;;======================================================================
;; Extended config lines, allows storing more hierarchial data in the config lines
;;   ABC a=1; b=hello world; c=a
;;
;; NOTE: implementation is quite limited. You currently cannot have
;;       semicolons in your string values.
;;======================================================================

;; convert string a=1; b=2; c=a silly thing; d=
;; to '((a . 1)(b . 2)(c . "a silly thing")(d . ""))
;;
(define (val->alist val #!key (convert #f))
  (let ((val-list (string-split-fields ";\\s*" val #:infix)))
    (if val-list
	(map (lambda (x)
	       (let ((f (string-split-fields "\\s*=\\s*" x #:infix)))
		 (case (length f)
		   ((0) `(,#f))  ;; null string case
		   ((1) `(,(string->symbol (car f))))
		   ((2) `(,(string->symbol (car f)) . ,(let ((inval (cadr f)))
							 (if convert (lazy-convert inval) inval))))
		   (else f))))
	     val-list)
	'())))

;; I don't want configf to turn into a weak yaml format but this extention is really useful
;;
(define (section->val-alist cfgdat section-name #!key (convert #f))
  (let ((section (get-section cfgdat section-name)))
    (map (lambda (item)
           (let ((key (car item))
                 (val (cadr item))) ;; BUG IN WAIT. sections are not returned as proper alists, should fix this.
             (cons key (val->alist val convert: convert))))
         section)))
  
;; read a config file, returns hash table of alists

;; read a config file, returns hash table of alists
;; adds to ht if given (must be #f otherwise)
;; allow-system:
;;    #f - do not evaluate [system
;;    #t - immediately evaluate [system and store result as string
;;    'return-procs -- return a proc taking ht as an argument that may be evaulated at some future time
;;    'return-string -- return a string representing a proc taking ht as an argument that may be evaulated at some future time
;; envion-patt is a regex spec that identifies sections that will be eval'd
;; in the environment on the fly
;; sections: #f => get all, else list of sections to gather
;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path)
;; apply-wildcards: #t/#f - apply vars from targets with % wildcards to all matching sections
;;
;; NOTE: apply-wild variable is intentional (but a better name would be good)
;;
(define (read-config path ht allow-system #!key (environ-patt #f)            (curr-section #f)   
		     (sections #f)              (settings (make-hash-table)) (keep-filenames #f)
		     (post-section-procs '())   (apply-wild #t) )
  (debug:print 9 *default-log-port* "BB> read-config > keep-filenames: " keep-filenames)
  (debug:print 9 *default-log-port* "START: " path)
;; (if *configdat*
;;     (common:save-pkt `((action . read-config)
;;       		 (f      . ,(cond ((string? path) path)
;;       				  ((port?   path) "port")
;;       				  (else (conc path))))
;;                        (T      . configf))
;;       	       *configdat* #t add-only: #t))
  (if (and (not (port? path))
	   (not (safe-file-exists? path))) ;; for case where we are handed a port
      (begin 
	(debug:print-info 1 *default-log-port* "read-config - file not found " path " current path: " (current-directory))
	;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read?
	#f) ;; (if (not ht)(make-hash-table) ht))
      (let* ((have-file  (string? path))
	     (inp        (if have-file
			     (open-input-file path)
			     path)) ;; we can be handed a port
	     (res        (if (not ht)(make-hash-table) ht))
	     (metapath   (if keep-filenames
			     path #f))
	     (process-wildcards  (lambda (res curr-section-name)
				   (if (and apply-wild
					    (or (string-contains curr-section-name "%")   ;; wildcard
						(string-match "/.*/" curr-section-name))) ;; regex
				       (begin
					 (apply-wildcards res curr-section-name)
					 (hash-table-delete! res curr-section-name))))))  ;; NOTE: if the section is a wild card it will be REMOVED from res 
	(let loop ((inl               (configf:read-line inp res (calc-allow-system allow-system curr-section sections) settings)) ;; (read-line inp))
		   (curr-section-name (if curr-section curr-section "default"))
		   (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere
		   (lead     #f))
	  (debug:print-info 8 *default-log-port* "curr-section-name: " curr-section-name " var-flag: " var-flag "\n   inl: \"" inl "\"")
	  (if (eof-object? inl) 
	      (begin
                ;; process last section for wildcards
                (process-wildcards res curr-section-name)
		(if have-file ;; we received a path, not a port, thus we are responsible for closing it.
		    (close-input-port inp))
		(if (list? sections) ;; delete all sections except given when sections is provided
		    (for-each
		     (lambda (section)
		       (if (not (member section sections))
			   (hash-table-delete! res section))) ;; we are using "" as a dumping ground and must remove it before returning the ht
		     (hash-table-keys res)))
		(debug:print 9 *default-log-port* "END: " path)
                res
                ) ;; retval
	      (regex-case 
	       inl 
	       (configf:comment-rx _                  (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
                                                            curr-section-name #f #f))
               
	       (configf:blank-l-rx _                  (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
                                                            curr-section-name #f #f))
	       (configf:settings   ( x setting val  )
                                   (begin
                                     (hash-table-set! settings setting val)
                                     (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
                                           curr-section-name #f #f)))
	       
	       (configf:initstr-rx ( x initstr  )
                                   (begin
				     (add-eval-string initstr)
                                     (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
                                           curr-section-name #f #f)))
               
	       (configf:include-rx ( x include-file )
                                   (let* ((curr-conf-dir (pathname-directory path))
                                          (full-conf     (if (and (absolute-pathname? include-file) (file-exists? include-file))
                                                             include-file
                                                             (nice-path 
                                                              (conc (if curr-conf-dir
                                                                        curr-conf-dir
                                                                        ".")
                                                                    "/" include-file))))
					  (all-matches (sort (handle-exceptions exn (list) (glob full-conf)) string<=?)))
				       (if (null? all-matches)
					   (begin
					     (debug:print '(2 9) #f "INFO: include file(s) matching " include-file " not found (called from " path ")")
					     (debug:print 2 *default-log-port* "        " full-conf))
					   (for-each
					    (lambda (fpath)
					      ;; (push-directory conf-dir)
					      (debug:print 9 *default-log-port* "Including: " full-conf)
					      (read-config fpath res allow-system environ-patt: environ-patt
							   curr-section: curr-section-name sections: sections settings: settings
							   keep-filenames: keep-filenames))
					    all-matches))
				       (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
					     curr-section-name #f #f)))
	       (configf:script-rx ( x include-script params);; handle-exceptions
                                  ;;    exn
                                  ;;    (begin
                                  ;;      (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.")
                                  ;;      (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
                                  (if (and (safe-file-exists? include-script)(file-execute-access? include-script))
                                      (let* ((local-allow-system  (calc-allow-system allow-system curr-section-name sections))
                                             (env-delta  (cfgdat->env-alist curr-section-name res local-allow-system))
                                             (new-inp-port
                                              (with-env-vars
                                               env-delta
                                               (lambda ()
                                                 (open-input-pipe (conc include-script " " params))))))
                                        (debug:print '(2 9) *default-log-port* "Including from script output: " include-script)
                                        ;;  (print "We got here, calling read-config next. Port is: " new-inp-port)
                                        (read-config new-inp-port res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames)
                                        (close-input-port new-inp-port)
                                        (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
                                      (begin
                                        (debug:print 0 *default-log-port* "Script not found or not exectutable: " include-script)
                                        (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))
                                  ) ;; )
	       (configf:section-rx ( x section-name )
                                   (begin
                                     ;; call post-section-procs
                                     (for-each 
                                      (lambda (dat)
                                        (let ((patt (car dat))
                                              (proc (cdr dat)))
                                          (if (string-match patt curr-section-name)
                                              (proc curr-section-name section-name res path))))
                                      post-section-procs)
                                     ;; after gathering the vars for a section and if apply-wildcards is true and if there is a wildcard in the section name process wildcards
                                     ;; NOTE: we are processing the curr-section-name, NOT section-name.
                                     (process-wildcards res curr-section-name)
                                     (if (not (hash-table-ref/default res section-name #f))(hash-table-set! res section-name '())) ;; ensure that mere mention of a section is not lost
                                     (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
                                           ;; if we have the sections list then force all settings into "" and delete it later?
                                           ;; (if (or (not sections) 
                                           ;;	      (member section-name sections))
                                           ;;	  section-name "") ;; stick everything into "". NOPE: We need new strategy. Put stuff in correct sections and then delete all sections later.
                                           section-name
                                           #f #f)))
	       (configf:key-sys-pr ( x key cmd      )
                                   (if (calc-allow-system allow-system curr-section-name sections)
                                       (let ((alist    (hash-table-ref/default res curr-section-name '()))
                                             (val-proc (lambda ()
                                                         (let* ((start-time (current-seconds))
                                                                (local-allow-system  (calc-allow-system allow-system curr-section-name sections))
                                                                (env-delta  (cfgdat->env-alist curr-section-name res local-allow-system))
                                                                (cmdres     (cmd-run->list cmd delta-env-alist-or-hash-table: env-delta)) ;; BB: here is where [system is exec'd.  needs to have env from other vars!
                                                                (delta      (- (current-seconds) start-time))
                                                                (status     (cadr cmdres))
                                                                (res        (car  cmdres)))
                                                           (debug:print-info 4 *default-log-port* "" inl "\n => " (string-intersperse res "\n"))
                                                           (if (not (eq? status 0))
                                                               (begin
                                                                 (debug:print-error 0 *default-log-port* "problem with " inl ", return code " status
                                                                                    " output: " cmdres)))
                                                           (if (> delta 2)
                                                               (debug:print-info 0 *default-log-port* "for line \"" inl "\"\n  command: " cmd " took " delta " seconds to run with output:\n   " res)
                                                               (debug:print-info 9 *default-log-port* "for line \"" inl "\"\n  command: " cmd " took " delta " seconds to run with output:\n   " res))
                                                           (if (null? res)
                                                               ""
                                                               (string-intersperse res " "))))))
                                         (hash-table-set! res curr-section-name 
                                                          (assoc-safe-add alist
                                                                                 key 
                                                                                 (case (calc-allow-system allow-system curr-section-name sections)
                                                                                   ((return-procs) val-proc)
                                                                                   ((return-string) cmd)
                                                                                   (else (val-proc)))
                                                                                 metadata: metapath))
                                         (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
                                       (loop (configf:read-line inp res
                                                                (calc-allow-system allow-system curr-section-name sections)
                                                                settings)
                                             curr-section-name #f #f)))
               
	       (configf:key-no-val ( x key val)
                                   (let* ((alist   (hash-table-ref/default res curr-section-name '()))
                                          (fval    (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces)
                                     (debug:print 10 *default-log-port* "   setting: [" curr-section-name "] " key " = #t")
                                     (safe-setenv key fval)
                                     (hash-table-set! res curr-section-name 
                                                      (assoc-safe-add alist key fval metadata: metapath))
                                     (loop (configf:read-line inp res
                                                              (calc-allow-system allow-system curr-section-name sections)
                                                              settings)
                                           curr-section-name key #f)))
               
	       (configf:key-val-pr ( x key unk1 val unk2 )
                                   (let* ((alist   (hash-table-ref/default res curr-section-name '()))
                                          (envar   (and environ-patt
							(string-search (regexp environ-patt) curr-section-name)
							(and (not (string-null? key))
							     (not (equal? "!" (substring key 0 1)))) ;; ! as leading character is a signature to NOT export to the environment
							;; (string-match "^.*:.*:.*$" key) ;; ;; something:something:something reserved for triggers in runconfigs
							)) 
                                          (realval (if envar
                                                       (eval-string-in-environment val)
                                                       val)))
                                     (debug:print-info 6 *default-log-port* "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name)
                                     (if envar (safe-setenv key realval))
                                     (debug:print 10 *default-log-port* "   setting: [" curr-section-name "] " key " = " val)
                                     (hash-table-set! res curr-section-name 
                                                      (assoc-safe-add alist key realval metadata: metapath))
                                     (loop (configf:read-line inp res
                                                              (calc-allow-system allow-system curr-section-name sections) settings)
                                           curr-section-name key #f)))
	       ;; if a continued line
	       (configf:cont-ln-rx ( x whsp val     )
                                   (let ((alist (hash-table-ref/default res curr-section-name '())))
                                     (if var-flag             ;; if set to a string then we have a continued var
                                         (let ((newval (conc 
                                                        (lookup res curr-section-name var-flag) "\n"
                                                        ;; trim lead from the incoming whsp to support some indenting.
                                                        (if lead
                                                            (string-substitute (regexp lead) "" whsp)
                                                            "")
                                                        val)))
                                           ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag)
                                           (hash-table-set! res curr-section-name 
                                                            (assoc-safe-add alist var-flag newval metadata: metapath))
                                           (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp)))
                                         (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
	       (else (debug:print-error 0 *default-log-port* "problem parsing " path ",\n   \"" inl "\"")
		     (set! var-flag #f)
		     (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
          ) ;; end loop
        )))

;; look at common:set-fields for an example of how to use the set-fields proc
;; pathenvvar will set the named var to the path of the config
;;
(define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)(set-fields #f)(keep-filenames #f))
  (let* ((curr-dir   (current-directory))
         (configinfo (find-config fname toppath: given-toppath))
	 (toppath    (car configinfo))
	 (configfile (cadr configinfo)))
    (if toppath (change-directory toppath)) 
    (if (and toppath pathenvvar)(setenv pathenvvar toppath))
    (let ((configdat  (if configfile 
			  (read-config configfile #f #t environ-patt: environ-patt
				       post-section-procs: (if set-fields (list (cons "^fields$" set-fields)   ) '())
				       #f
                                       keep-filenames: keep-filenames))))
      (if toppath (change-directory curr-dir))
      (list configdat toppath configfile fname))))

(define (lookup cfgdat section var)
  (if (hash-table? cfgdat)
      (let ((sectdat (hash-table-ref/default cfgdat section '())))
	(if (null? sectdat)
	    #f
	    (let ((match (assoc var sectdat)))
	      (if match ;; (and match (list? match)(> (length match) 1))
		  (cadr match)
		  #f))
	    ))
      #f))

;; use to have definitive setting:
;;  [foo]
;;  var yes
;;
;;  (var-is? cfgdat "foo" "var" "yes") => #t
;;
(define (var-is? cfgdat section var expected-val)
  (equal? (lookup cfgdat section var) expected-val))

;; safely look up a value that is expected to be a number, return
;; a default (#f unless provided)
;;
(define (lookup-number cfgdat section varname #!key (default #f))
  (let* ((val (lookup cfgdat section varname))
         (res (if val
                  (string->number (string-substitute "\\s+" "" val #t))
                  #f)))
    (cond
     (res  res)
     (val  (debug:print 0 *default-log-port* "ERROR: no number found for [" section "], " varname ", got: " val))
     (else default))))

(define (section-vars cfgdat section)
  (let ((sectdat (hash-table-ref/default cfgdat section '())))
    (if (null? sectdat)
	'()
	(map car sectdat))))

(define (get-section cfgdat section)
  (hash-table-ref/default cfgdat section '()))

(define (set-section-var cfgdat section var val)
  (let ((sectdat (get-section cfgdat section)))
    (hash-table-set! cfgdat section
                     (assoc-safe-add sectdat var val))))

    ;;(append (filter (lambda (x)(not (assoc var sectdat))) sectdat)
    ;;	    (list var val))))

;; moved to common
;; (define (setup)
;;   (let* ((configf (find-config "megatest.config"))
;; 	 (config  (if configf (read-config configf #f #t) #f)))
;;     (if config
;; 	(setenv "RUN_AREA_HOME" (pathname-directory configf)))
;;     config))

;;======================================================================
;; Non destructive writing of config file
;;======================================================================

(define (compress-multi-lines fdat)
  ;; step 1.5 - compress any continued lines
  (if (null? fdat) fdat
	(let loop ((hed (car fdat))
		   (tal (cdr fdat))
		   (cur "")
		   (led #f)
		   (res '()))
	  ;; ALL WHITESPACE LEADING LINES ARE TACKED ON!!
	  ;;  1. remove led whitespace
	  ;;  2. tack on to hed with "\n"
	  (let ((match (string-match configf:cont-ln-rx hed)))
	    (if match ;; blast! have to deal with a multiline
		(let* ((lead (cadr match))
		       (lval (caddr match))
		       (newl (conc cur "\n" lval)))
		  (if (not led)(set! led lead))
		  (if (null? tal) 
		      (set! fdat (append fdat (list newl)))
		      (loop (car tal)(cdr tal) newl led res))) ;; NB// not tacking newl onto res
		(let ((newres (if led 
				  (append res (list cur hed))
				  (append res (list hed)))))
		  ;; prev was a multiline
		  (if (null? tal)
		      newres
		      (loop (car tal)(cdr tal) "" #f newres))))))))

;; note: I'm cheating a little here. I merely replace "\n" with "\n         "
(define (expand-multi-lines fdat)
  ;; step 1.5 - compress any continued lines
  (if (null? fdat) fdat
      (let loop ((hed (car fdat))
		 (tal (cdr fdat))
		 (res '()))
	(let ((newres (append res (list (string-substitute (regexp "\n") "\n         " hed #t)))))
	  (if (null? tal)
	      newres
	      (loop (car tal)(cdr tal) newres))))))

(define (file->list fname)
  (if (safe-file-exists? fname)
      (let ((inp (open-input-file fname)))
	(let loop ((inl (read-line inp))
		   (res '()))
	  (if (eof-object? inl)
	      (begin
		(close-input-port inp)
		(reverse res))
	      (loop (read-line inp)(cons inl res)))))
      '()))

;; raw basic write config in ini format
;;
(define (write-config cfgdat fname)
  (with-output-to-file fname
    (lambda ()
      (config->ini cfgdat))))

;;       (for-each
;;        (lambda (section)
;; 	 (let ((sec-dat (hash-table-ref cfgdat section)))
;; 	   (for-each (lambda (entry)(print (car entry) " " (cadr entry))) sec-dat)))
;;        (sort (hash-table-keys cfgdat) (lambda (a b)(string<= a b)))))))

;;======================================================================
;; Write a config
;;   0. Given a refererence data structure "indat"
;;   1. Open the output file and read it into a list
;;   2. Flatten any multiline entries
;;   3. Modify values per contents of "indat" and remove absent values
;;   4. Append new values to the section (immediately after last legit entry)
;;   5. Write out the new list 
;;======================================================================

(define (write-merge-config indat fname #!key (required-sections '()))
  (let* (;; step 1: Open the output file and read it into a list
	 (fdat    (file->list fname))
	 (refdat  (make-hash-table))
	 (sechash (make-hash-table)) ;; current section hash, init with hash for "default" section
	 (new     #f) ;; put the line to be used in new, if it is to be deleted the set new to #f
	 (secname #f))

    ;; step 2: Flatten multiline entries
    (if (not (null? fdat))(set! fdat (compress-multi-lines fdat)))

    ;; step 3: Modify values per contents of "indat" and remove absent values
    (if (not (null? fdat))
	(let loop ((hed  (car fdat))
		   (tal  (cadr fdat))
		   (res  '())
		   (lnum 0))
	  (regex-case 
	   hed
	   (configf:comment-rx _                  (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f))
	   (configf:blank-l-rx _                  (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f))
	   (configf:section-rx ( x section-name ) (let ((section-hash (hash-table-ref/default refdat section-name #f)))
						    (if (not section-hash)
							(let ((newhash (make-hash-table)))
							  (hash-table-set! refdat section-name newhash)
							  (set! sechash newhash))
							(set! sechash section-hash))
						    (set! new hed) ;; will append this at the bottom of the loop
						    (set! secname section-name)
						    ))
	   ;; No need to process key cmd, let it fall though to key val
	   (configf:key-val-pr ( x key val      )
		       (let ((newval (lookup indat secname key))) ;; secname was sec. I think that was a bug
			 ;; can handle newval == #f here => that means key is removed
			 (cond 
			  ((equal? newval val)
			   (set! res (append res (list hed))))
			  ((not newval) ;; key has been removed
			   (set! new #f))
			  ((not (equal? newval val))
			     (hash-table-set! sechash key newval)
			     (set! new (conc key " " newval)))
			  (else
			   (debug:print-error 0 *default-log-port* "problem parsing line number " lnum "\"" hed "\"")))))
	   (else
	    (debug:print-error 0 *default-log-port* "Problem parsing line num " lnum " :\n   " hed )))
	  (if (not (null? tal)) 
	      (loop (car tal)(cdr tal)(if new (append res (list new)) res)(+ lnum 1)))
	  ;; drop to here when done processing, res contains modified list of lines
	  (set! fdat res)))

    ;; step 4: Append new values to the section
    (for-each 
     (lambda (section)
       (let ((sdat   '()) ;; append needed bits here
	     (svars  (section-vars indat section)))
	 (for-each 
	  (lambda (var)
	    (let ((val (lookup refdat section var)))
	      (if (not val) ;; this one is new
		  (begin
		    (if (null? sdat)(set! sdat (list (conc "[" section "]"))))
		    (set! sdat (append sdat (list (conc var " " val))))))))
	  svars)
	 (set! fdat (append fdat sdat))))
     (delete-duplicates (append required-sections (hash-table-keys indat))))

    ;; step 5: Write out new file
    (with-output-to-file fname 
      (lambda ()
	(for-each 
	 (lambda (line)
	   (print line))
	 (expand-multi-lines fdat))))))

;;======================================================================
;; refdb
;;======================================================================

;; reads a refdb into an assoc array of assoc arrays
;;   returns (list dat msg)
(define (read-refdb refdb-path)
  (let ((sheets-file  (conc refdb-path "/sheet-names.cfg")))
    (if (not (safe-file-exists? sheets-file))
	(list #f (conc "ERROR: no refdb found at " refdb-path))
	(if (not (file-read-access? sheets-file))
	    (list #f (conc "ERROR: refdb file not readable at " refdb-path))
	    (let* ((sheets (with-input-from-file sheets-file
			     (lambda ()
			       (let loop ((inl (read-line))
					  (res '()))
				 (if (eof-object? inl)
				     (reverse res)
				     (loop (read-line)(cons inl res)))))))
		   (data   '()))
	      (for-each 
	       (lambda (sheet-name)
		 (let* ((dat-path  (conc refdb-path "/" sheet-name ".dat"))
			(ref-dat   (read-config dat-path #f #t))
			(ref-assoc (map (lambda (key)
					  (list key (hash-table-ref ref-dat key)))
					(hash-table-keys ref-dat))))
				   ;; (hash-table->alist ref-dat)))
		   ;; (set! data (append data (list (list sheet-name ref-assoc))))))
		   (set! data (cons (list sheet-name ref-assoc) data))))
	       sheets)
	      (list data "NO ERRORS"))))))

;; map over all pairs in a three level hierarchial alist and apply a function to the keys/val
;;
(define (map-all-hier-alist data proc #!key (initproc1 #f)(initproc2 #f)(initproc3 #f))
  (for-each 
   (lambda (sheetname)
     (let* ((sheettmp  (assoc sheetname data))
	    (sheetdat  (if sheettmp (cadr sheettmp) '())))
       (if initproc1 (initproc1 sheetname))
       (for-each 
	(lambda (sectionname)
	  (let* ((sectiontmp  (assoc sectionname sheetdat))
		 (sectiondat  (if sectiontmp (cadr sectiontmp) '())))
	    (if initproc2 (initproc2 sheetname sectionname))
	    (for-each
	     (lambda (varname)
	       (let* ((valtmp (assoc varname sectiondat))
		      (val    (if valtmp (cadr valtmp) "")))
		 (proc sheetname sectionname varname val)))
	     (map car sectiondat))))
	(map car sheetdat))))
   (map car data))
  data)

;;======================================================================
;;  C O N F I G   T O / F R O M   A L I S T
;;======================================================================

(define (config->alist cfgdat)
  (hash-table->alist cfgdat))

(define (alist->config adat)
  (let ((ht (make-hash-table)))
    (for-each
     (lambda (section)
       (hash-table-set! ht (car section)(cdr section)))
     adat)
    ht))

;; if 
(define (read-alist fname)
  (handle-exceptions
      exn
      #f
    (alist->config
     (with-input-from-file fname read))))

(define (write-alist cdat fname #!key (locker #f)(unlocker #f))
  (if (and locker (not (locker fname)))
      (debug:print 0 *default-log-port* "INFO: Could not get lock on " fname))
  (let* ((dat  (config->alist cdat))
         (res
          (begin
            (with-output-to-file fname ;; first write out the file
              (lambda ()
                (pp dat)))
            
            (if (file-exists? fname)   ;; now verify it is readable
                (if (read-alist fname)
                    #t ;; data is good.
                    (begin
                      (handle-exceptions
                       exn
                       #f
                       (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.")
                       (delete-file fname))
                      #f))
                #f))))
    (if unlocker (unlocker fname))
    res))
  
;; convert config hash-table/list data to ini format
;;
(define (config->ini data)
  (map 
   (lambda (section)
     (let ((section-name (car section))
	   (section-dat  (cdr section)))
       (print "\n[" section-name "]")
       (map (lambda (dat-pair)
	      (let* ((var (car dat-pair))
		     (val (cadr dat-pair))
		     (fname (if (> (length dat-pair) 2)(caddr dat-pair) #f)))
		(if fname (print "# " var "=>" fname))
		(print var " " val)))
	    section-dat))) ;;       (print "section-dat: " section-dat))
   (hash-table->alist data)))

;(use trace)
;(trace-call-sites #t)
;(trace read-config)

)

;; Copyright 2007-2010, Matthew Welland.
;;
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;;
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

;;;; mtconfig.setup

;; compile the code into dynamically loadable shared objects
;; and install as modules

(compile -s mtconfigf.scm)
(standard-extension 'mtconfigf "mtconfigf.so")

(load "../mtdebug/mtdebug.scm")
(import mtdebug)
(load "mtconfigf.scm")
(import (prefix mtconfigf config:))

(use mtdebug)
;; configure mtconfigf
(let* ((normal-fn debug:print)
       (info-fn   debug:print-info)
       (error-fn  debug:print-error)
       (default-port (current-output-port)))
  (config:set-debug-printers normal-fn info-fn error-fn default-port))


(use test)

(let* ((cfgdat
        (config:read-config "tests/test.config" #f #f)))

  
  (test #f "value" (config:lookup cfgdat "basic" "key"))
  (test #f 2 (config:lookup-number cfgdat "basic" "two"))
  
  )

(config:add-eval-string "(define (customfunc) \"hello\")")
(let* ((cfgdat
        (config:read-config "tests/test2.config" #f #f)))
  (test #f "bar" (config:lookup cfgdat "schemy" "rgetreftarget"))
  (test #f "baz" (config:lookup cfgdat "schemy" "rgetrefdefault"))
  (test #f "2" (config:lookup cfgdat "schemy" "addup"))
  (test #f 2 (config:lookup-number cfgdat "schemy" "addup"))
  (test #f "hello" (config:lookup cfgdat "schemy" "custom"))
  )

(test #f
      (conc "hello " (get-environment-variable "USER"))
      (config:eval-string-in-environment "hello $USER"))

(let* ((cfgdat
        (config:read-config "tests/test3.config" #f #t)))
  (test #f "hello" (config:lookup cfgdat "systemic" "hello"))
  (test #f
        (conc "hello " (get-environment-variable "USER"))
        (config:lookup cfgdat "systemic" "hellouser"))

  )

[basic]
key value
two 2

[default]
deffoo baz

[a-target]
foo bar

[.dvars]
target a-target


[schemy]
addup #{scheme (+ 1 1)}
custom #{scheme (customfunc)}
rgetreftarget #{rget foo}
rgetrefdefault #{rget deffoo}

[systemic]
hello [system echo hello]
hellouser [system echo hello $USER]

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

(use format typed-records) ;; RADT => purpose of json format??

(declare (unit rmt))
(declare (uses api))
(declare (uses http-transport))
(declare (uses rmtmod))
(import (prefix rmtmod rmtmod:))

(declare (uses ulex))
(import (prefix ulex ulex:))

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

;; (declare (uses rmtmod))

;; (import rmtmod)

;;
;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!
;;

;; generate entries for ~/.megatestrc with the following
;;
;;  grep define ../rmt.scm | grep rmt: |perl -pi -e 's/\(define\s+\((\S+)\W.*$/\1/'|sort -u

      (debug:print 0 *default-log-port* "query rest needed. blocking for 0.1 second. cmd="cmd", run id="rid", params="params)
      (thread-sleep! 0.1) ;; force a rest of a half second
      (set! *rmt-query-last-rest-time* now)
      (set! *rmt-query-last-call-time* now))
     (else ;; sufficient rests have occurred, just record the last query time
      (set! *rmt-query-last-call-time* now)))))

(define *alldat* #f)
  
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f))
  (if (equal? (configf:lookup *configdat* "setup" "newapi") "yes")
      (begin
	(if (not *alldat*) ;; add wait here if *toppath* is not set
	    (set! *alldat* (rmtmod:create-alldat *toppath*)))
	(rmtmod:send-receive *alldat* cmd rid params))
      (rmt:send-receive-orig cmd rid params attemptnum: 1 area-dat: #f)))

;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname))
;;
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected
(define (rmt:send-receive-orig cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected

  #;(common:telemetry-log (conc "rmt:"(->string cmd))
                        payload: `((rid . ,rid)
                                   (params . ,params)))

  (if (not (equal? (configf:lookup *configdat* "setup" "query-rest") "no"))
      (rmt:query-rest cmd rid params))
  
  (if (> attemptnum 2)
      (debug:print 0 *default-log-port* "INFO: attemptnum in rmt:send-receive is " attemptnum))
    
  (cond

;; 
;;     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 rmtmod))
(declare (uses commonmod))
(declare (uses apimod))
;; (declare (uses apimod.import))
(declare (uses ulex))

;; (include "ulex/ulex.scm")

(module rmtmod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
(import (prefix commonmod cmod:))
(use tcp6)
(import apimod)
(import (prefix ulex ulex:))

(defstruct alldat
  (areapath #f)
  (ulexdat  #f)
  (ulexdat  (ulex:make-udat))
  )

;; create-alldat also sets up our tcp server
;;
(define (create-alldat areapath)
  (let* ((adat (make-alldat))
	 (udat (alldat-ulexdat adat)))
    (alldat-areapath-set! adat areapath)
    (if (not (ulex:start-server-find-port udat (+ 4242 (random 5000))))
	(print "Server NOT started properly"))
    (thread-start! (make-thread
		    (lambda ()
		      (ulex:ulex-handler-loop udat))
		    "Ulex handler loop thread"))
    ;; exit handler needed here
    adat))

(define (send-receive adat cmd rid params)
  (let* ((dbpath (conc (alldat-areapath adat) "/dbs/" (modulo (or rid 0) 1000) ".db")))
    (ulex:remote-call (alldat-ulexdat adat) dbpath 'megatest cmd params)))

;; return the handle struct for sending queries to a specific database
;;  - initializes the connection object if this is the first access
;;    - finds the "captain" and asks who to talk to for the given dbfname
;;    - establishes the connection to the current dbowner
;;
#;(define (rmt:connect alldat dbfname dbtype)
  (let* ((ulexdat    (or (alldat-ulexdat alldat)

;; 
;;     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 ulex))
(declare (uses pkts))
;;(declare (uses pkts))

(include "ulex/ulex.scm")

all : example

#  telemetry/telemetry.so netutil/ulex-netutil.so portlogger/portlogger.so
ulex.so : ulex.scm
	chicken-install

telemetry/telemetry.so : telemetry/telemetry.scm
	cd telemetry && chicken-install

example : ulex.so example.scm
	csc example.scm

test : ulex.so
	csi -b tests/run.scm

portlogger/portlogger.so : portlogger/portlogger.scm
	cd portlogger && chicken-install
	csi -s portlogger/test.scm

netutil/ulex-netutil.so: netutil/ulex-netutil.scm
	cd netutil && chicken-install

clean:
	rm -f example *so */*so *.import.* */*.import.*

;;; dbi: Minimal gasket to postgresql, sqlite3 and mysql
;;;
;; Copyright (C) 2007-2016 Matt Welland
;; Redistribution and use in source and binary forms, with or without
;; modification, is permitted.
;;
;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
;; DAMAGE.

(use regex srfi-18 matchable)

(load "ulex.scm")
(import (prefix ulex ulex:))

(create-directory "ulexdb" #t)
(create-directory "pkts"   #f)

(define *area* (ulex:make-area
		dbdir:   (conc (current-directory) "/ulexdb")
		pktsdir: (conc (current-directory) "/pkts") 
		))
(define (toplevel-command . args) #f)
(use readline)

;; two reserved keys in the ulex registration hash table are:
;;   dbinitsql => a list of sql statements to be executed at db creation time
;;   dbinitfn  => a function of two params; dbh, the sql-de-lite db handle and
;;                dbfname, the database filename
;;
(ulex:register-batch
 *area*
 'dbwrite
 `((dbinitsql . ("CREATE TABLE IF NOT EXISTS messages (id INTEGER PRIMARY KEY, message TEXT, author TEXT, msg_time INTEGER);"))
   (savemsg   . "INSERT INTO messages (message,author) VALUES (?,?)")
   ))
		 
(ulex:register-batch
 *area*
 'dbread
 `((dbinitsql . ("CREATE TABLE IF NOT EXISTS messages (id INTEGER PRIMARY KEY, message TEXT, author TEXT, msg_time INTEGER);"))
   (getnum    . "SELECT COUNT(*) FROM messages")
   (getsome   . "SELECT * FROM messages LIMIT 10")
   ))
		 
(define (worker mode-in)
  (let* ((start (current-milliseconds))
        (iters-per-sample 10)
	(mode (string->symbol mode-in))
	(max-count (case mode
		     ((all) 60)
		     (else  1000)))
	(num-calls 0)
	(report (lambda ()		  
		  (let ((delta (- (current-milliseconds) start)))
		    (print "Completed " num-calls " in " delta
			   " for " (/ num-calls (/ delta 1000)) " calls per second")))))
    (if (eq? mode 'repl)
	(begin
	  (import extras) ;; might not be needed
	  ;; (import csi)
	  (import readline)
	  (import apropos)
	  (import (prefix ulex ulex:))
	  (install-history-file (get-environment-variable "HOME") ".example_history") ;;  [homedir] [filename] [nlines])
	  (current-input-port (make-readline-port "example> "))
	  (repl))
	(let loop ((count 0))
	  ;; (print "loop count=" count)
	  (for-each
	   (lambda (dbname)
	     ;;(print "TOP OF LAMBDA")
	     (case mode
	       ((all)
		(let ((start-time (current-milliseconds))
		      (message    (conc "Test message #" count "! From pid: " (current-process-id)))
		      (user (current-user-name)))
		  (ulex:call *area* dbname 'savemsg `(,message ,user))
		  (for-each (lambda (n)
			      (print "have this many " (ulex:call *area* dbname 'getnum  '()) " records in main.db"))
			    (iota 10))
		  (set! num-calls (+ num-calls 11))
		  ))
	       
	       ((ping)
		(let ((srvrs (ulex:get-all-server-pkts *area*)))
		  (for-each
		   (lambda (srv)
		     (print "Pinging " srv)
		     (ulex:ping *area* srv))
		   srvrs)))
	       ((fullping)
		(let ((srvrs (ulex:get-all-server-pkts *area*)))
		  (for-each
		   (lambda (srv)
		     (let ((ipaddr (alist-ref 'ipaddr srv))
			   (port   (any->number (alist-ref 'port srv))))
		       (print "Full Ping to " srv)
		       (ulex:ping *area* ipaddr port)))
		   srvrs)))
	       ((passive)
		(thread-sleep! 10))
	       ))
	   '("main.db")) ;; "test.db" "run-1.db" "run-2.db" "run-3.db" "run-4.db"))
	  #;(thread-sleep! 0.001)
	  #;(let ((now (current-milliseconds)))
	    (if (and (> now start)
		     (eq? (modulo count iters-per-sample) 0))
		(begin
		  (print "queries per second: "(* 1000.0 (/ iters-per-sample (- now start))))
		  (set! count 0)
		  (set! start (current-milliseconds)))))
	  ;; (print "count: " count " max-count: " max-count)
	  (if (< count max-count)
	      (loop (+ count 1)))))
    (report)
    (ulex:clear-server-pkt *area*)
    (thread-sleep! 5) ;; let others keep using this server (needs to be built in to ulex)
        ;; (print "Doing stuff")
    ;; (thread-sleep! 10)
    (print "Done doing stuff")))

(define (run-worker)
  (thread-start!
   (make-thread (lambda ()
		  (thread-sleep! 5)
		  (worker "all"))
		"worker")))

(define (main . args)
    (if (member (car args) '("repl"))
	(print "NOTE: No exit timer started.")
	(thread-start! (make-thread (lambda ()
				      (thread-sleep! (* 60 5))
				      (ulex:clear-server-pkt *area*)
				      (thread-sleep! 5)
				      (exit 0)))))
    (print "Launching server")
    (ulex:launch *area*)
    (print "LAUNCHED.")
    (thread-sleep! 0.1) ;; chicken threads bit quirky? need little time for launch thread to get traction?
    (apply worker args)
    )

;;======================================================================
;; Strive for clean exit handling
;;======================================================================

;; Ulex shutdown is handled within Ulex itself.

#;(define (server-exit-procedure)
  (on-exit (lambda ()
	     ;; close the databases, ensure the pkt is removed!
	     ;; (thread-sleep! 2)
	     (ulex:shutdown *area*)
	     0)))

;; Copied from the SDL2 examples.
;;
;; Schedule quit! to be automatically called when your program exits normally.
#;(on-exit server-exit-procedure)

;; Install a custom exception handler that will call quit! and then
;; call the original exception handler. This ensures that quit! will
;; be called even if an unhandled exception reaches the top level.
#;(current-exception-handler
 (let ((original-handler (current-exception-handler)))
   (lambda (exception)
     (server-exit-procedure)
     (original-handler exception))))

(if (file-exists? ".examplerc")
    (load ".examplerc"))

(let ((args-in (argv))) ;; command-line-arguments)))
  (let ((args (match
	       args-in
	       (("csi" "--" args ...) args)
	       ((_ args ...) args)
	       (else args-in))))
    (if (null? args)
	(begin
	  (print "Usage: example [mode]")
	  (print "  where mode is one of:")
	  (print "   ping     : only do pings between servers")
	  (print "   fullping : ping with response via processing queue")
	  (print "   unix     : only do unix commands")
	  (print "   read     : only do ping, unix and db reads")
	  (print "   all      : do pint, unix, and db reads and writes")
	  (exit))
	(apply main args))))

(use ulex-netutil)
(use test)

(test #f #t (not (not (member "127.0.0.1" (get-all-ips)))))

;; -*- scheme -*-
(
; Your egg's license:
(license "BSD")

; Pick one from the list of categories (see below) for your egg and enter it
; here.
(category db)

(needs foreign )

; A list of eggs required for TESTING ONLY.  See the `Tests' section.
(test-depends test)

(author "Brandon Barclay")
(synopsis "Get all IP addresses for all interfaces."))

(repo fossil "http://www.kiatoa.com/cgi-bin/fossils/{egg-name}")
(uri zip "http://www.kiatoa.com/cgi-bin/fossils/{egg-name}/zip/{egg-name}.zip?uuid={egg-release}")
(release "0.1")

;;; ulex: Distributed sqlite3 db
;;;
;; Copyright (C) 2018 Matt Welland
;; Redistribution and use in source and binary forms, with or without
;; modification, is permitted.
;;
;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
;; DAMAGE.

;;======================================================================
;; ABOUT:
;;   See README in the distribution at https://www.kiatoa.com/fossils/ulex
;; NOTES:
;;   provides all ipv4 addresses for all interfaces
;;
;;======================================================================

;; get IP addresses from ALL interfaces
(module ulex-netutil
    (get-all-ips get-my-best-address get-all-ips-sorted)

(import scheme chicken data-structures foreign ports regex-case posix)


;; #include <stdio.h>
;; #include <netinet/in.h>
;; #include <string.h>
;; #include <arpa/inet.h>

(foreign-declare "#include \"sys/types.h\"")
(foreign-declare "#include \"sys/socket.h\"")
(foreign-declare "#include \"ifaddrs.h\"")
(foreign-declare "#include \"arpa/inet.h\"")

;; get IP addresses from ALL interfaces
(define get-all-ips
  (foreign-safe-lambda* scheme-object ()
    "

// from https://stackoverflow.com/questions/17909401/linux-c-get-default-interfaces-ip-address :


    C_word lst = C_SCHEME_END_OF_LIST, len, str, *a;
//    struct ifaddrs *ifa, *i;
//    struct sockaddr *sa;

    struct ifaddrs * ifAddrStruct = NULL;
    struct ifaddrs * ifa = NULL;
    void * tmpAddrPtr = NULL;

    if ( getifaddrs(&ifAddrStruct) != 0)
      C_return(C_SCHEME_FALSE);

//    for (i = ifa; i != NULL; i = i->ifa_next) {
    for (ifa = ifAddrStruct; ifa != NULL; ifa = ifa->ifa_next) {
        if (ifa->ifa_addr->sa_family==AF_INET) { // Check it is
            // a valid IPv4 address
            tmpAddrPtr = &((struct sockaddr_in *)ifa->ifa_addr)->sin_addr;
            char addressBuffer[INET_ADDRSTRLEN];
            inet_ntop(AF_INET, tmpAddrPtr, addressBuffer, INET_ADDRSTRLEN);
//            printf(\"%s IP Address %s\\n\", ifa->ifa_name, addressBuffer);
            len = strlen(addressBuffer);
            a = C_alloc(C_SIZEOF_PAIR + C_SIZEOF_STRING(len));
            str = C_string(&a, len, addressBuffer);
            lst = C_a_pair(&a, str, lst);
        } 

//        else if (ifa->ifa_addr->sa_family==AF_INET6) { // Check it is
//            // a valid IPv6 address
//            tmpAddrPtr = &((struct sockaddr_in6 *)ifa->ifa_addr)->sin6_addr;
//            char addressBuffer[INET6_ADDRSTRLEN];
//            inet_ntop(AF_INET6, tmpAddrPtr, addressBuffer, INET6_ADDRSTRLEN);
////            printf(\"%s IP Address %s\\n\", ifa->ifa_name, addressBuffer);
//            len = strlen(addressBuffer);
//            a = C_alloc(C_SIZEOF_PAIR + C_SIZEOF_STRING(len));
//            str = C_string(&a, len, addressBuffer);
//            lst = C_a_pair(&a, str, lst);
//       }

//       else {
//         printf(\" not an IPv4 address\\n\");
//       }

    }

    freeifaddrs(ifa);
    C_return(lst);

"))

;; Change this to bias for addresses with a reasonable broadcast value?
;;
(define (ip-pref-less? a b)
  (let* ((rate (lambda (ipstr)
                 (regex-case ipstr
                             ( "^127\\." _ 0 )
                             ( "^(10\\.0|192\\.168\\.)\\..*" _ 1 )
                             ( else 2 ) ))))
    (< (rate a) (rate b))))
  

(define (get-my-best-address)
  (let ((all-my-addresses (get-all-ips))
        ;;(all-my-addresses-old (vector->list (hostinfo-addresses (hostname->hostinfo (get-host-name)))))
        )
    (cond
     ((null? all-my-addresses)
      (get-host-name))                                          ;; no interfaces?
     ((eq? (length all-my-addresses) 1)
      (car all-my-addresses))                      ;; only one to choose from, just go with it
     
     (else
      (car (sort all-my-addresses ip-pref-less?)))
     ;; (else 
     ;;  (ip->string (car (filter (lambda (x)                      ;; take any but 127.
     ;;    			 (not (eq? (u8vector-ref x 0) 127)))
     ;;    		       all-my-addresses))))

     )))

(define (get-all-ips-sorted)
  (sort (get-all-ips) ip-pref-less?))

)

;; Copyright 2007-2018, Matthew Welland.
;;
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;;
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

;;;; ulex.setup
(standard-extension 'ulex-netutil "0.1")

;; -*- scheme -*-
(
; Your egg's license:
(license "BSD")

; Pick one from the list of categories (see below) for your egg and enter it
; here.
(category db)

(needs foreign )

; A list of eggs required for TESTING ONLY.  See the `Tests' section.
(test-depends test sqlite3 regex)

(author "Matthew Welland")
(synopsis "thoughtfully optain tcp port."))

(repo fossil "http://www.kiatoa.com/cgi-bin/fossils/{egg-name}")
(uri zip "http://www.kiatoa.com/cgi-bin/fossils/{egg-name}/zip/{egg-name}.zip?uuid={egg-release}")
(release "0.1")

;;======================================================================
;; P O R T L O G G E R  -  track ports used on the current machine
;;======================================================================

;; 

(module portlogger
    (pl-open-run-close pl-find-port pl-release-port pl-open-db pl-get-prev-used-port pl-get-port-state pl-take-port)
  (import scheme
          posix
          chicken
          data-structures
                                        ;ports
          extras
                                        ;files
                                        ;mailbox
                                        ;telemetry
          regex
                                        ;regex-case
          
          )
  (use (prefix sqlite3 sqlite3:))
  (use posix)
  (use regex)
  
  (define (pl-open-db fname)
    (let* ((avail    #t) ;; for now - assume wait on journal not needed (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away
	   (exists   (file-exists? fname))
	   (db       (if avail 
		         (sqlite3:open-database fname)
		         (begin
			   (system (conc "rm -f " fname))
			   (sqlite3:open-database fname))))
	   (handler  (sqlite3:make-busy-timeout 136000))
	   (canwrite (file-write-access? fname)))
      (sqlite3:set-busy-handler! db handler)
      (sqlite3:execute db "PRAGMA synchronous = 0;")
      (sqlite3:execute
       db
       "CREATE TABLE IF NOT EXISTS ports (
            port INTEGER PRIMARY KEY,
            state TEXT DEFAULT 'not-used',
            fail_count INTEGER DEFAULT 0,
            update_time TIMESTAMP DEFAULT (strftime('%s','now')) );")
      db))

  (define (pl-open-run-close proc . params)
    (let* ((fname	 (conc "/tmp/." (current-user-name) "-portlogger.db"))
	   (avail	 #t)) ;; (tasks:wait-on-journal fname 10))) ;; wait up to about 10 seconds for the journal to go away
      ;; (handle-exceptions
      ;;	exn
      ;;	(begin
      ;;	  ;; (release-dot-lock fname)
      ;;	  (debug:print-error 0 *default-log-port* "pl-open-run-close failed. " proc " " params)
      ;;	  (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
      ;;	  (debug:print 5 *default-log-port* "exn=" (condition->list exn))
      ;;	  (if (file-exists? fname)(delete-file fname)) ;; brutally get rid of it
      ;;	  (print-call-chain (current-error-port)))
      (let* (;; (lock   (obtain-dot-lock fname 2 9 10))
	     (db	    (pl-open-db fname))
	     (res    (apply proc db params)))
        (sqlite3:finalize! db)
        ;; (release-dot-lock fname)
        res)))
  ;; )

  ;; (fold-row PROC INIT DATABASE SQL . PARAMETERS) 
  (define (pl-take-port db portnum)
    (let* ((qry1 "INSERT INTO ports (port,state) VALUES (?,?);")
	   (qry2 "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;"))
      (let* ((curr (pl-get-port-state db portnum))
	     (res	 (case (string->symbol (or curr "n/a"))
		           ((released)	    (sqlite3:execute db qry2 "taken" portnum) 'taken)
		           ((not-tried n/a) (sqlite3:execute db qry1 portnum "taken") 'taken)
		           ((taken)							       'already-taken)
		           ((failed)							       'failed)
		           (else							       'error))))
        ;; (print "res=" res)
        res)))

  (define (pl-get-prev-used-port db)
    ;; (handle-exceptions
    ;;     exn
    ;;     (with-output-to-port (current-error-port)
    ;;	(lambda ()
    ;;	  (print "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db")
    ;;	  (print " message: " ((condition-property-accessor 'exn 'message) exn))
    ;;	  (print "exn=" (condition->list exn))
    ;;	  (print-call-chain) ;;	 (current-error-port))
    ;;	  (print "Continuing anyway.")
    ;;	  #f))
    (let ((res (sqlite3:fold-row
	        (lambda (var curr)
		  (or curr var curr))
	        #f
	        db "SELECT port FROM ports WHERE state='released';")))
      (if res res #f)))
  ;; )

  (define (pl-find-port db acfg #!key (lowport 32768))
    ;;(slite3:with-transaction
    ;; db
    ;; (lambda ()
    (let loop ((numtries 0))
      (let* ((portnum (or (pl-get-prev-used-port db)
			  (+ lowport ;; top of registered ports is 49152 but let's use ports in the registered range
			     (random (- 64000 lowport))))))
	;; (handle-exceptions
	;;     exn
	;;     (with-output-to-port (current-error-port)
	;;	 (lambda ()
	;;	   (print "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db")
	;;	   (print " message: " ((condition-property-accessor 'exn 'message) exn))
	;;	   (print "exn=" (condition->list exn))
	;;	   (print-call-chain)
	;;	   (print "Continuing anyway.")))
	(pl-take-port db portnum) ;; always "take the port"
	(if (pl-is-port-available portnum)
	    portnum
	    (begin
	      (pl-set-port db portnum "taken")
	      (loop (add1 numtries)))))))


  ;; set port to "released", "failed" etc.
  ;; 
  (define (pl-set-port db portnum value)
    (sqlite3:execute db "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;") value portnum)

  ;; set port to "released", "failed" etc.
  ;; 
  (define (pl-get-port-state db portnum)
    (let ((res (sqlite3:fold-row	  ;; get the state of given port or "not-tried"
	        (lambda (var curr)  ;; function on init/last current
		  (or curr var curr))
	        #f	  ;; init
	        db "SELECT state FROM ports WHERE port=?;"
	        portnum)))	    ;; the parameter to the query
      (if res res #f)))

  ;; (slite3:exec (slite3:sql db "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;") value portnum))

  ;; release port
  (define (pl-release-port db portnum)
    (sqlite3:execute db "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;" "released" portnum)
    (sqlite3:change-count db))

  ;; set port to failed (attempted to take but got error)
  ;;
  (define (pl-set-failed db portnum)
    (sqlite3:execute db "UPDATE ports SET state='failed',fail_count=fail_count+1,update_time=strftime('%s','now') WHERE port=?;" portnum)
    (sqlite3:change-count db))

  ;; pulled from mtut - TODO: remove from mtut, find a way *without* using netstat
  ;;
  (define (pl-is-port-available port-num)
    (let-values (((inp oup pid)
		  (process "netstat" (list  "-tulpn" ))))
      (let loop ((inl (read-line inp)))
        (if (not (eof-object? inl))
	    (begin 
	      (if (string-search (regexp (conc ":" port-num "\\s+")) inl)
		  #f
		  (loop (read-line inp))))
	    #t))))

  ) ;; end module