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 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
mofiles/dbmod.o : mofiles/configfmod.o

# 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 (execute-requests params)
)

;; redefines
(define config-lookup configf:lookup)
(define configf:read-file read-config)

;; safely look up a value that is expected to be a number, return
;; a default (#f unless provided)
;;
(define (configf:lookup-number cfgdat section varname #!key (default #f))
  (let* ((val (configf: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))))

				(map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ"))))
	       (vector-set! *state-status* 0
			    (lambda (state color)
			      (for-each 
			       (lambda (btn)
				 (let* ((name     (iup:attribute btn "TITLE"))
					(newcolor (if (equal? name state) color "192 192 192")))
				   (if (not (colors-similar? newcolor (iup:attribute btn "FGCOLOR")))
				       (iup:attribute-set! btn "FGCOLOR" newcolor))))
			       btns)))
	       btns))
      (apply iup:hbox
	     (iup:label "STATUS:" #:size "30x")
	     (let* ((btns  (map (lambda (status)
				  (let ((btn (iup:button status
							 #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10"

				(map cadr *common:std-statuses*)))) ;; (list  "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP"))))
	       (vector-set! *state-status* 1
			    (lambda (status color)
			      (for-each 
			       (lambda (btn)
				 (let* ((name     (iup:attribute btn "TITLE"))
					(newcolor (if (equal? name status) color "192 192 192")))
				   (if (not (colors-similar? newcolor (iup:attribute btn "FGCOLOR")))
				       (iup:attribute-set! btn "FGCOLOR" newcolor))))
			       btns)))
	       btns))))))

(define (dashboard-tests:run-a-step info)
  #t)

;; (define (dashboard-tests:step-run-control testdat stepname testconfig)

					  (else
					   teststate)))
			   (button     (vector-ref columndat rown))
			   (color      (car (gutils:get-color-for-state-status teststate teststatus)))
			   (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR"))
			   (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE")))
		      (if (not (equal? curr-color color))
			  #;(iup:attribute-set! button "BGCOLOR" color)
			  (iup:attribute-set! button "FGCOLOR" color))
		      (if (not (equal? curr-title buttontxt))
			  (iup:attribute-set! button "TITLE" (conc "<span weight=\"bold\">"  buttontxt "</span>")))
		      (vector-set! buttondat 0 run-id)
		      (vector-set! buttondat 1 color)
		      (vector-set! buttondat 2 buttontxt)
		      (vector-set! buttondat 3 testdat)
		      (vector-set! buttondat 4 run-key)))
		(set! rown (+ rown 1))))
	    (dboard:tabdat-all-test-names tabdat)))

	   ;; 					   (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-empty-runs tabdat) "+HideE" "-HideE"))
	   ;; 					   (mark-for-update tabdat))))
	   (set! hide (iup:button "Hide"
				  #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL"
				  #:action (lambda (obj)
					     (dboard:tabdat-hide-not-hide-set! tabdat #t) ;; (not (dboard:tabdat-hide-not-hide tabdat)))
					     ;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-not-hide tabdat) "HideTests" "NotHide"))
					     (iup:attribute-set! hide "FGCOLOR" sel-color)
					     (iup:attribute-set! show "FGCOLOR" nonsel-color)
					     (mark-for-update tabdat))))
	   (set! show (iup:button "Show"
				  #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL"
				  #:action (lambda (obj)
					     (dboard:tabdat-hide-not-hide-set! tabdat #f) ;; (not (dboard:tabdat-hide-not-hide tabdat)))
					     (iup:attribute-set! show "FGCOLOR" sel-color)
					     (iup:attribute-set! hide "FGCOLOR" nonsel-color)
					     (mark-for-update tabdat))))
	   (iup:attribute-set! hide "FGCOLOR" sel-color)
	   (iup:attribute-set! show "FGCOLOR" nonsel-color)
	   ;; (dboard:tabdat-hide-not-hide-button-set! tabdat hideit) ;; never used, can eliminate ...
           (iup:vbox
            (iup:hbox hide show)
            sort-lb))) 
	)

        ;; insert extra widget here

	(loop (+ runnum 1) 0 (make-vector ntests) '()))
       (else
	(let* ((button-key (mkstr runnum testnum))
	       (butn       (iup:button
			    "" ;; button-key 
			    #:size (conc cell-width btn-height )
			    #:expand "HORIZONTAL"
			    #:MARKUP "YES"
			    #:fontsize btn-fontsz
			    #:button-cb
			    (lambda (obj a pressed x y btn . rem)
			      ;; (print "pressed= " pressed " x= " x " y= " y " rem=" rem " btn=" btn " string? " (string? btn))
			      (if  (substring-index "3" btn)
				   (if (eq? pressed 1)
				       (let* ((toolpath (car (argv)))

  (let* ((tmp-area            (common:get-db-tmp-area))
	 (server-start        (conc tmp-area "/.server-start"))
	 (server-started      (conc tmp-area "/.server-started"))
	 (start-time          (common:lazy-modification-time server-start))
	 (started-time        (common:lazy-modification-time server-started))
	 (server-starting     (< start-time started-time)) ;; if start-time is less than started-time then a server is still starting
	 (start-time-old      (> (- (current-seconds) start-time) 5))
         (cleanup-proc        (lambda (msg) ;; would like to use (modulo (current-seconds) 60) instead of process-id to wrap filenames
                                (let* ((serv-fname      (conc "server-" (current-process-id) "-" (get-host-name) ".log"))
				       (new-fname       (conc "server-" (modulo (current-seconds) 60) "-" (get-host-name) ".log"))
                                       (full-serv-fname (conc *toppath* "/logs/" serv-fname))
                                       ;; (new-serv-fname  (conc *toppath* "/logs/" "defunct-" serv-fname))
				       (new-serv-fname  (conc *toppath* "/logs/" new-fname))
				       )
                                  (debug:print 0 *default-log-port* msg)
                                  (if (common:file-exists? full-serv-fname)
				      (with-output-to-pipe "at now + 10 minutes" (lambda ()
										   (print "mv -f " full-serv-fname " " new-serv-fname)))
                                      ;; (system (conc "sleep 10;mv -f " full-serv-fname " " new-serv-fname))
                                      (debug:print 0 *default-log-port* "INFO: cannot move " full-serv-fname " to " new-serv-fname))
                                  (exit)))))
    (if (and (not start-time-old) ;; last server start try was less than five seconds ago
	     (not server-starting))
	(begin
	  (cleanup-proc "NOT starting server, there is either a recently started server or a server in process of starting")
	  (exit)))
    ;; lets not even bother to start if there are already three or more server files ready to go
    (let* ((num-alive   (server:get-num-alive (server:get-list *toppath*))))
      (if (> num-alive 3)
          (begin
            (cleanup-proc (conc "ERROR: Aborting server start because there are already " num-alive " possible servers either running or starting up"))
            (exit))))
  (common:save-pkt `((action . start)
		     (T      . server)
		     (pid    . ,(current-process-id)))

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]

Queries:
   show [areas|contours... ] : show areas, contours or other section from megatest.config
   gendot                    : generate a graphviz dot file from pkts.

Contour actions:
   process                   : runs import, rungen and dispatch 
   go                        : runs import, rungen and dispatch every five minutes forever
			     
Trigger propagation actions:
   tsend a=b,c=d...          : send trigger info to all recpients in the [listeners] section
   tlisten -port N           : listen for trigger info on port N
			     
Selectors 		     
  -immediate                 : apply this action immediately, default is to queue up actions

			    (handle-exceptions
				exn
				(begin
				  (print-call-chain)
				  (print "FAILED TO RUN RUNNAME MAPPER " callname " FOR AREA " area)
				  (print " message: " ((condition-property-accessor 'exn 'message) exn))
				  runname)
			      (print "(mapper " (string-intersperse (map conc (list runkey runname area area-path reason contour mode-patt)) ", ") ")")
			      (mapper runkey runname area area-path reason contour mode-patt))
			    (case callname
			      ((auto #f) runname)
			      (else   runtrans)))))
	 (new-target     target) ;; I believe we will want target manipulation here .. (map-targets xlatr-key runkey area contour))
	 (actual-action  (if action
			     (if (equal? action "sync-prepend")

	 ;;    (if (not (member key *legal-params*))
	 ;; 	(hash-table-delete! adjargs key))) ;; we need to delete any params intended for mtutil
	 ;;  (hash-table-keys adjargs))
	 (let-values (((uuid pkt)
		       (command-line->pkt *action* adjargs #f area-path: area-path new-ss: new-ss)))
           (print "run log @ " (conc (current-directory) "/" uuid "-" *action* ".log"))
	   (write-pkt pktsdir uuid pkt))))
      ((dispatch import rungen process go)
       (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
	      (mtconf    (car mtconfdat))
	      (toppath   (configf:lookup mtconf "scratchdat" "toppath"))
	      (period    (configf:lookup-number mtconf "mtutil" "autorun-period" default: 300))
	      (rest-time (configf:lookup-number mtconf "mtutil" "autorun-rest"   default: 30)))
	 (print "Using period="period" and rest time="rest-time)
	 (case (string->symbol *action*)
	   ((process)  (begin
			 (common:load-pkts-to-db mtconf)
			 (generate-run-pkts mtconf toppath)
			 (common:load-pkts-to-db mtconf)
			 (dispatch-commands mtconf toppath)))
	   ((import)   (common:load-pkts-to-db mtconf)) ;; import pkts
	   ((rungen)   (generate-run-pkts mtconf toppath))
	   ((dispatch) (dispatch-commands mtconf toppath))
	   ;; [mtutil]
	   ;; # approximate interval between run processing in mtutil (seconds)
	   ;; autorun-period 300
	   ;; # minimal rest period between processing 
	   ;; autorun-rest   30
	   ((go)
	    ;; determine if I'm the boss
	    (if (file-exists? "mtutil-go.pid")
		(begin
		  (print "ERROR: mtutil go is already running under host and pid " (with-input-from-file "mtutil-go.pid" read-line)
			 ". Please kill that process and remove the file \"mutil-go.pid\" and try again.")
		  (exit)))
	    (with-output-to-file "mtutil-go.pid" (lambda ()(print (get-host-name) " " (current-process-id))))
	    (print "Starting long running import, rungen, and process loop")
	    (if (file-exists? "do-not-run-mtutil-go")
		(begin
		  (print "NOTE: Removing flag file "(current-directory)"/do-not-run-mtutil-go")
		  (delete-file* "do-not-run-mtutil-go")))
	    (let loop ((last-run (- (current-seconds) (+ period 10))) ;; fake out first time in 
		       (this-run (current-seconds)))
	      (if (file-exists? "do-not-run-mtutil-go")
		  (begin
		    (print "File do-not-run-mtutil-go exists, exiting.")
		    (delete-file* "mtutil-go.pid")
		    (exit)))
	      (let ((delta (- this-run last-run)))
		(if (>= delta period)
		    (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
			   (mtconf    (car mtconfdat)))
		      (print "Running import at " (current-seconds))
		      (common:load-pkts-to-db mtconf)
		      (print "Running generate run pkts at " (current-seconds))
		      (generate-run-pkts mtconf toppath)
		      (print "Running run dispatch at " (current-seconds))
		      (common:load-pkts-to-db mtconf)
		      (dispatch-commands mtconf toppath)
		      (print "Done running import, generate, and dispatch done in " (- (current-seconds) this-run))
		      (print "NOTE: touch " (current-directory) "/do-not-run-mtutil-go to kill this runner.")
		      (loop this-run (current-seconds)))
		    (let ((now (current-seconds)))
		      (print "Sleeping " rest-time " seconds, next run in aproximately " (- period (- now last-run)) " seconds")
		      (thread-sleep! rest-time)
		      (loop last-run (current-seconds))))))
	    (delete-file* "mtutil-go.pid")))))
      ;; misc
      ((show)
       (if (> (length remargs) 0)
	   (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
		  (mtconf    (car mtconfdat))
		  (sect-dat (configf:get-section mtconf (car remargs))))
	     (if sect-dat

                                   )

                                  )

                                )))
                           (loop (nn-recv rep))))
		       (print "ERROR: Port " portnum " already in use. Try another port")))))))




    ((tlisten)
     (if (null? remargs)
         (print "ERROR: useage for tlisten is \"mtutil tlisten portnum\"")
         (let ((portnum (string->number (car remargs))))
           
           (if (not portnum)
               (print "ERROR: the portnumber parameter must be a number, you gave: " (car remargs))
               (begin
                 (if (not (is-port-in-use portnum))  
                     (let* ((rep       (start-nn-server portnum))
                            (mtconfdat (simple-setup (args:get-arg "-start-dir")))
                            (mtconf    (car mtconfdat))
                            (contact   (configf:lookup mtconf "listener" "owner"))
                            (script    (configf:lookup mtconf "listener" "script")))
                       (print "Listening on port " portnum " for messages.")
                       (set-signal-handler! signal/int
					    (lambda (signum) 
					      (set! *time-to-exit* #t)
  					      (debug:print-error 0 *default-log-port* "Received signal " signum
								 " sending email befor exiting !!")
  					      (let ((email-body (mtut:stml->string
								 (s:body
								  (s:p (conc "Received signal " signum
									     ". Lister has been terminated on host "
									     (get-environment-variable "HOST") ". "))))))
             					(sendmail contact "Listner has been terminated." email-body  use_html: #t))
					      (exit)))
		       (set-signal-handler! signal/term  (lambda (signum) 
							   (set! *time-to-exit* #t)
  							   (debug:print-error 0 *default-log-port* "Received signal "
									      signum " sending email befor exiting !!")
  							   (let ((email-body (mtut:stml->string
									      (s:body
									       (s:p (conc "Received signal " signum
											  ". Lister has been terminated on host "
											  (get-environment-variable "HOST") ". "))))))
             					             (sendmail contact "Listner has been terminated." email-body  use_html: #t))
							   (exit)))

		       ;; (set-signal-handler! signal/term special-signal-handler)
                       
                         (let loop ((instr (nn-recv rep)))
                             (nn-send rep "ok")
                             (let ((ctime (date->string (current-date)))) 
                             (if  (equal? instr "time-to-die")
                              (begin 
                              (debug:print 0 *default-log-port* ctime " received '" instr "'. Time to sucide." )
                               (let ((pid  (current-process-id)))

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

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

		  (client:setup areapath)
		  #f))))

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

(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id

(define *alldat* (rmtmod:create-alldat *toppath*))
  
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f))
  (if (equal? (configf:lookup *configdat* "setup" "newapi") "yes")
      (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-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 (> attemptnum 2)
      (debug:print 0 *default-log-port* "INFO: attemptnum in rmt:send-receive is " attemptnum))
    
  (cond
   ((> attemptnum 2) (thread-sleep! 0.05))
   ((> attemptnum 10) (thread-sleep! 0.5))

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

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

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

(import (prefix ulex ulex:))

(defstruct alldat
  (areapath #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)

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

(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

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

;;;; portlogger.setup
(standard-extension 'portlogger "0.1")

(use portlogger)
(use test)

(test-begin "portlogger")
(use (prefix sqlite3 sqlite3:))

(define *port* #f)
(define *area* #f)
(test #f #f (begin
              (pl-open-run-close
               (lambda (db b)
                 (pl-get-prev-used-port db))
               *area*)
              #f))
(test #f #f (pl-open-run-close (lambda (db b)(pl-get-port-state db 1234567)) *area*))
(test #f #f (number? (pl-open-run-close (lambda (db b)(pl-take-port db 123456)) *area*)))
(test #f #t (number? (let ((port (pl-open-run-close pl-find-port *area*)))
		       (set! *port* port)
		       port)))
(test #f 1 (pl-open-run-close pl-release-port *port*))
(test #f "released" (pl-open-run-close
		     (lambda (db)
		       (sqlite3:first-result db "select state from ports where port=?" *port*))))

(test-end "portlogger")

#!/bin/bash

CMD=$1

make example 

for x in $(seq 1 10);do
  ./example $CMD 2>&1| tee run$x.log &
done

wait

(load "telemetry.scm")

(import telemetry)

(print 1)
(telemetry-open "localhost" 12346)
(print 2)
(telemetry-send "goo") 
(print 3)
(telemetry-send "goo2") 
(print 4)

(load "telemetry.scm")
(import telemetry)
(print "before")
(use mailbox)
(use mailbox-threads)
(use srfi-18)

(set! handler-seq 0)
(define (handler msg)
  (set! handler-seq (add1 handler-seq))
  (print "=============")
  (print handler-seq msg))
  
(telemetry-server 12346 handler)

  
(print "after")

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

; A list of eggs dbi 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 udp mailbox-threads z3 base64 )

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

(author "Brandon Barclay")
(synopsis "A telemetry send/receive system using udp."))

(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")

(module telemetry
    (telemetry-open telemetry-send telemetry-close telemetry-server
                    telemetry-show-debugs telemetry-hide-debugs )
  
  (import chicken scheme data-structures
          base64 srfi-18
          z3 udp posix extras ports mailbox mailbox-threads)

  (use udp)
  (use base64)
  (use z3)
  (use mailbox-threads)
  
  (define *telemetry:telemetry-log-state* 'startup)
  (define *telemetry:telemetry-log-socket* #f)

  (define *debug-print-flag* #f)

  (define (telemetry-show-debugs)
    (set! *debug-print-flag* #t))

  (define (telemetry-hide-debugs)
    (set! *debug-print-flag* #f))

  (define (debug-print  . args)
    (if *debug-print-flag*
        (apply print "telemetry> " args)))

  (define (make-telemetry-server-thread port callback)
    (let* ((thr
            (make-thread
             (lambda ()
               (let* ((s (udp-open-socket)))
                 (udp-bind! s #f port)
                 ;;(udp-connect! s "localhost" port)
                 (let loop ((seq 0))
                   (debug-print "loop seq="seq)
                   (receive (n data from-host from-port) (udp-recvfrom s 640000)
                     (let* ((encapsulated-payload
                             (with-input-from-string
                                 (z3:decode-buffer
                                  (base64-decode data)) read))
                            (callback-res `( (from-host . ,from-host)
                                             (from-port . ,from-port)
                                             (data-len  . ,n)
                                             ,@encapsulated-payload )))
                       (callback callback-res))
                     
                       )
                   (loop (add1 seq)))
                 (udp-close-socket s))))))
      (thread-start! thr)
      thr))

  (define (telemetry-server port handler-callback)
    (let* ((serv-thread (make-telemetry-server-thread port handler-callback)))
      (print serv-thread)
      (thread-join! serv-thread)))

  
  (define (telemetry-open serverhost serverport)
    (let* ((user (or (get-environment-variable "USER") "unknown"))
           (host (or (get-environment-variable "HOST") "unknown")))
      (set! *telemetry:telemetry-log-state*
            (handle-exceptions
             exn
             (begin
               (debug-print "telemetry-open udp port failure")
               'broken)
             (if (and serverhost serverport user host)
                 (let* ((s (udp-open-socket)))
                   ;;(udp-bind! s #f 0)
                   (udp-connect! s serverhost serverport)
                   (set! *telemetry:telemetry-log-socket* s)
                   'open)
                 'not-needed)))))


  (define (telemetry-close)
    (when (or (member *telemetry:telemetry-log-state* '(broken-or-no-server-preclose open)) *telemetry:telemetry-log-socket*)
      (handle-exceptions
       exn
       (begin
         (define *telemetry:telemetry-log-state* 'closed-fail)
         (debug-print "telemetry-telemetry-log closure failure")
         )
       (begin
         (define *telemetry:telemetry-log-state* 'closed)
         (udp-close-socket *telemetry:telemetry-log-socket*)
         (set! *telemetry:telemetry-log-socket* #f)))))

    (define (telemetry-send payload)
    (if (eq? 'open *telemetry:telemetry-log-state*)
        (handle-exceptions
         exn
         (begin
           (debug-print "telemetry-telemetry-log comms failure ; disabled (no server?)")
           (define *telemetry:telemetry-log-state* 'broken-or-no-server-preclose)
           (telemetry-close)
           (define *telemetry:telemetry-log-state* 'broken-or-no-server)
           (set! *telemetry:telemetry-log-socket* #f)
           )
         (if (and *telemetry:telemetry-log-socket* payload) 
             (let* ((user (or (get-environment-variable "USER") "unknown"))
                    (host (or (get-environment-variable "HOST") "unknown"))
                    (encapsulated-payload
                     `( (user . ,user)
                        (host . ,host)
                        (pid . ,(current-process-id))
                        (payload . ,payload) ) )
                    (msg
                     (base64-encode
                      (z3:encode-buffer
                       (with-output-to-string (lambda () (pp encapsulated-payload)))))))
               ;;(debug-print "pre-send")
               (let ((res (udp-send *telemetry:telemetry-log-socket* msg)))
                 ;;(debug-print "post-send >"res"<")
                 res)
               
               )))) )


  )

;; 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 'telemetry "0.1")

(include "ulex.scm")

(use trace)

(import (prefix ulex ulex:))
(trace-call-sites #t)

;; (trace ulex:receive-message ulex:std-peer-handler ulex:process-db-queries ulex:work-queue-add ulex:call send-message ulex:get-best-server ulex:ping)
(set! *default-error-port* (current-output-port))

(ulex:call *area* "test.db" 'savemsg '("my message" "matt"))

(define *servers* (ulex:get-all-server-pkts *area*))

(define numofrecords (ulex:call *area* "test.db" 'getnum  '()))
;; (define bunchofrecords (ulex:call *area* "test.db" 'getsome '()))

(use test (prefix sqlite3 sqlite3:) posix)
(if (file-exists? "ulex.scm")
    (load "ulex.scm")
    (load "../ulex.scm"))

(use trace)
(trace-call-sites #t)

(import ulex ) ;; (import (prefix ulex ulex:))


(test-begin "faux-mtdb")
;; pre-clean

(for-each (lambda (dir)
            (if (directory-exists? dir)
                (system (conc "/bin/rm -rf ./"dir)))
            (system (conc "/bin/mkdir -p ./"dir))
            )
          '("faux-mtdb" "faux-mtdb-pkts"))


(let* ((area     (make-area dbdir: "faux-mtdb" pktsdir: "faux-mtdb-pkts"))
       (specfile "tests/mt-spec.sexpr")
       (dbname "faux-mt.db"))
  (launch area)
  (initialize-area-calls-from-specfile area specfile)

  
  (let* ((target-name "a/b/c/d")
         (insert-result (call area dbname 'new-target (list target-name)))
         (test-target-id (caar (call area dbname 'target-name->target-id (list target-name))))
         (test-target-name (caar (call area dbname 'target-id->target-name (list 1)))))
    (test #f #t insert-result)
    (test #f 1 test-target-id )
    (test #f target-name test-target-name )
    )
  
  (test #f #t (shutdown area)))

;; thought experiment - read cursors
;; (let* ((cursor (call area dbname 'get-target-names '())))
;;   (let loop ((row (cursor)))
;;     (cond
;;      ((not row) #t)
;;      (else
;;       (print "ROW IS "row)
;;       (loop (cursor))))))


(test-end "faux-mtdb")


       

(
 (dbwrite .
          (
           (dbinitsql . (
                         "create table if not exists targets(id integer primary key,name)"
                         "create table if not exists runs(id integer primary key,target_id,name,path,state,status)"
                         "create table if not exists tests(id integer primary key,run_id,name,path,state,status,host)"
                         "create table if not exists test_steps(id integer primary key,test_id,name,state)" ))
           
           ( new-target . "insert into targets (name) values(?);")
           ( new-run    . "insert into runs (target_id,name,path,state,status) values(?,?,\"/dev/null\",\"NOT STARTED\",\"n/a\")")
           ( new-test    . "insert into tests values(?,?,?,\"/dev/null\",\"NOT STARTED\")")
           ( update-one-run_id-state-status . "update runs set state=? status=? where id=?" ) 
           ( update-one-test_id-state-status . "update tests set state=? status=? where id=?" )
           ( update-matching-tests-state-status . "update tests set state=? status=? where run_id=?, state like ?, status like ?")
           )
          )
 (dbread .
         (
          (get-targets . "select id,name from targets")
          (target-name->target-id . "select id from targets where name=?")
          (target-id->target-name . "select name from targets where id=?")
          (check-test-state-status . "select state,status from tests where id=?")
          )
         )

 )
          

(use test
     (prefix sqlite3 sqlite3:)
     posix
     ;; ulex-netutil rpc
     pkts
     mailbox
     hostinfo
     regex
     tcp6)

(include "ulex.scm")
;; (use (prefix ulex ulex:))
;; (if (file-exists? "ulex.scm")
;;     (load "ulex.scm")
;;     (load "../ulex.scm"))

(use trace)
(trace-call-sites #t)

(import ulex) ;; (import (prefix ulex ulex:))

(trace
 ;; find-or-setup-captain
 ;; get-all-captain-pkts
 ;; setup-as-captain
 ;; get-winning-pkt
 ;; ping
 ;; remove-captain-pkt
 ;; start-server-find-port
 ;; connect-server
 )

(test-begin "addresses")
(test #f #t (not (null? (get-all-ips))))
(test #f #t (string? (get-my-best-address)))
(test-end   "addresses")

;;======================================================================
;; Setup
;;======================================================================

(system "rm -rf testulexdb testpkts")
(create-directory "testulexdb" #t)
(create-directory "testpkts"   #t)

;;======================================================================
;; Captainship
;;======================================================================

(define *udat1* (make-udat))
(test #f #t (udat? (start-server-find-port *udat1* (+ 4242 (random 5000)))))

(test-begin "captainship")
(test #f #t (list? (get-all-captain-pkts  *udat1*)))
(test #f #t (udat? (let ((res (find-or-setup-captain *udat1*)))(print res) res)))
(test-end   "captainship")

;; ; (define *area* (make-area dbdir: "testulexdb" pktsdir: "testpkts"))
;; ; 
;; ; (define *port* #f)
;; ; 
;; ; ;;======================================================================
;; ; ;; Ulex-db
;; ; ;;======================================================================
;; ; 
;; ; (test-begin "ulex-db")
;; ; (test #f #t (equal? (area-dbdir *area*) "testulexdb"))
;; ; (test #f #t (thread? (thread-start! (make-thread (lambda ()(launch *area*)) "server"))))
;; ; (thread-sleep! 1)
;; ; (test #f 1  (update-known-servers *area*))
;; ; (test #f #t (list? (get-all-server-pkts *area*)))
;; ; (test #f (area-myaddr *area*) (cadr (ping *area* (area-myaddr *area*)(area-port *area*))))
;; ; 
;; ; (let loop ((count 10))
;; ;   (if (null? (get-all-server-pkts *area*))
;; ;       (if (> count 0)
;; ; 	  (begin
;; ; 	    (thread-sleep! 1)
;; ; 	    (print "waiting for server pkts")
;; ; 	    (loop (- count 1))))))
;; ; (test #f #t (let ((spkts (get-all-server-pkts *area*)))
;; ; 	      (and (list spkts) (> (length spkts) 0))))
;; ; (test #f #t (begin (register-batch
;; ; 		    *area*
;; ; 		    'dbwrite ;; this is the call type
;; ; 		    `((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 (?,?)")
;; ; 		      ;; (readmsg   . "SELECT * FROM messages WHERE author=?;")
;; ; 		      
;; ; 		      ))
;; ; 		   #t))
;; ; 
;; ; (test #f #t (calldat? (get-rentry *area* 'dbinitsql)))
;; ; (define cdat1 (get-rentry *area* 'dbinitsql))
;; ; (test #f #t (list? (get-best-server *area* "test.db" 'savemsg)))
;; ; (test #f #t (eq? 'dbwrite (calldat-ctype cdat1)))
;; ; (test #f #t (list? (get-rsql *area* 'dbinitsql)))
;; ; (test #f #t  (dbdat? (open-db *area* "test.db")))
;; ; 
;; ; (test #f #t (dbdat? (let ((dbh (get-dbh *area* "test.db")))
;; ; 		      (save-dbh *area* "test.db" dbh)
;; ; 		      dbh)))
;; ; (test #f #t (dbdat? (let ((dbh (get-dbh *area* "test.db")))
;; ; 		      dbh)))
;; ; 
;; ; ;(test #f '(#t "db write submitted" #t)  (call *area* "test.db" 'savemsg '("Test message!" "matt")))
;; ; (test #f #t  (call *area* "test.db" 'savemsg '("Test message!" "matt")))
;; ; ;;(thread-sleep! 15);; server needs time to process the request (it is non-blocking)
;; ; ;; (test #f #t (shutdown *area*))
;; ; ;; (test #f 0 (calc-server-score *area* "test.db"  (area-pktid *area*)))
;; ; 
;; ; (test #f #t (list? (get-best-server *area* "test.db" (area-pktid *area*))))
;; ; (define *best-server* (car (get-best-server *area* "test.db" (area-pktid *area*))))
;; ; (pp *best-server*)
;; ; (define *server-pkt*  (hash-table-ref/default (area-hosts *area*) (area-pktid *area*) #f))
;; ; (define *server-ip*   (alist-ref 'ipaddr *server-pkt*))
;; ; (define *server-port* (any->number (alist-ref 'port *server-pkt*)))
;; ; (test #f #t (list? (ping      *area* *server-ip* *server-port*)))
;; ; 
;; ; (test #f #t (process-db-queries *area* "test.db"))
;; ; (test #f #f (process-db-queries *area* "junk.db"))
;; ; ;; (test #f #t (cadr (full-ping *area* *server-pkt*)))
;; ; 
;; ; 
;; ; (test-end "ulex-db")
;; ; 
;; ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ; 
;; ; (test-begin "faux-mtdb")
;; ; ;; pre-clean
;; ; 
;; ; #;(for-each (lambda (dir)
;; ;             (if (directory-exists? dir)
;; ;                 (system (conc "/bin/rm -rf ./"dir)))
;; ;             (system (conc "/bin/mkdir -p ./"dir))
;; ;             )
;; ;           '("faux-mtdb" "faux-mtdb-pkts"))
;; ; 
;; ; 
;; ; (let* ((area     *area*) ;; (make-area dbdir: "faux-mtdb" pktsdir: "faux-mtdb-pkts"))
;; ;        (specfile "tests/mt-spec.sexpr")
;; ;        (dbname   "faux-mt.db"))
;; ;   ;; (launch area)
;; ;   (initialize-area-calls-from-specfile area specfile)
;; ;   (let* ((target-name "a/b/c/d")
;; ;          (insert-result (call area dbname 'new-target (list target-name)))
;; ;          (test-target-id (caar (call area dbname 'target-name->target-id (list target-name))))
;; ;          (test-target-name (caar (call area dbname 'target-id->target-name (list 1)))))
;; ;     (test #f #t insert-result)
;; ;     (test #f 1 test-target-id )
;; ;     (test #f target-name test-target-name )
;; ;     )
;; ;   (test #f #t (list? (get-best-server *area* "test.db" 'savemsg)))
;; ;   (thread-sleep! 5)
;; ;   (test #f #t (begin (shutdown area) #t)))
;; ;   
;; ; (test #f #t (process-db-queries *area* "test.db"))
;; ; (test #f #f (process-db-queries *area* "junk.db"))
;; ; 
;; ; ;; thought experiment - read cursors
;; ; ;; (let* ((cursor (call area dbname 'get-target-names '())))
;; ; ;;   (let loop ((row (cursor)))
;; ; ;;     (cond
;; ; ;;      ((not row) #t)
;; ;   ;;      (else
;; ; ;;       (print "ROW IS "row)
;; ; ;;       (loop (cursor))))))
;; ; 
;; ;   
;; ; (test-end "faux-mtdb")
;; ; 
;; ; ;;======================================================================
;; ; ;; Portlogger tests
;; ; ;;======================================================================
;; ; 
;; ; ;; (test-begin "portlogger")
;; ; ;; 
;; ; ;; (test #f #f (begin (pl-open-run-close (lambda (db b)(pl-get-prev-used-port db)) *area*) #f))
;; ; ;; (test #f #f (pl-open-run-close (lambda (db b)(pl-get-port-state db 1234567)) *area*))
;; ; ;; (test #f #f (number? (pl-open-run-close (lambda (db b)(pl-take-port db 123456)) *area*)))
;; ; ;; (test #f #t (number? (let ((port (pl-open-run-close pl-find-port *area*)))
;; ; ;; 		       (set! *port* port)
;; ; ;; 		       port)))
;; ; ;; (test #f 1 (pl-open-run-close pl-release-port *port*))
;; ; ;; (test #f "released" (pl-open-run-close
;; ; ;; 		     (lambda (db)
;; ; ;; 		       (sqlite3:first-result db "select state from ports where port=?" *port*))))
;; ; ;; 
;; ; ;; (test-end "portlogger")
;; ; 

;;======================================================================
;; network utilities
;;======================================================================

(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?))

)

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

; A list of eggs dbi 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 rpc pkts mailbox sqlite3)

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

(author "Matt Welland")
(synopsis "A distributed mesh-like layer for sqlite3."))

(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")

;;  start-server-find-port  ;; gotta have a server port ready from the very begining

;; udata    - all the connection info, captain, server, ulex db etc. MUST BE PASSED IN
;; dbpath   - full path and filename of the db to talk to or a symbol naming the db?
;; callname - the remote call to execute
;; params   - parameters to pass to the remote call
;;
(define (remote-call udata dbpath dbtype callname params)
  (start-server-find-port udata) ;; ensure we have a local server
  (find-or-setup-captain udata)
  ;; look at connect, process-request, send, send-receive
  (let-values (((cookie-key host-port)(get-db-owner udata dbpath dbtype)))
    (if (and cookie-key host-port)
	(send-receive udata host-port callname cookie-key params)
	#f)))

;;======================================================================
;; KEY FUNCTIONS - THESE ARE TOO BE EXPOSED AND USED
;;======================================================================

;; connection setup and management functions

;; This is the basic setup command. Must always be
;; called before connecting to a db using connect.
;;
;; find or become the captain
;; setup and return a ulex object
;;
(define (find-or-setup-captain udata #!optional (tries 0))
  ;; see if we already have a captain and if the lease is ok
  (if (and (udat-captain-address udata)
	   (udat-captain-port    udata)
	   (< (current-seconds) (udat-captain-lease udata)))
      udata
      (let* ((cpkts (get-all-captain-pkts udata)) ;; read captain pkts
	     (captn (get-winning-pkt cpkts)))

	      (udat-captain-lease-set!   udata (+ (current-seconds) 10))
	      (let-values (((success pingtime)(ping udata (conc ipaddr ":" port))))
		(if success
		    udata
		    (begin
		      (print "Found unreachable captain at " ipaddr ":" port ", removing pkt")
		      (remove-captain-pkt udata captn)
		      (if (< tries 20)
			  (find-or-setup-captain udata (+ tries 1))
			  #f)))))
	    (begin
	      (setup-as-captain udata)  ;; this saves the thread to captain-thread and starts the thread
	      (if (< tries 20)
		  (find-or-setup-captain udata (+ tries 1))
		  #f))))))

;; connect to a specific dbfile
;;   - if already connected - return the dbowner host-port
;;   - ask the captain who to talk to for this db
;;   - put the entry in the dbowners hash as dbfile => host-port
;;
(define (connect udata dbfname dbtype)

  (let* ((host-port (udat-captain-host-port udata)))
    (if host-port
	(let* ((cookie (make-cookie udata))
	       (msg    #f) ;; (conc dbname " " dbtype))
	       (params `(,dbname ,dbtype))
	       (res    (send udata host-port 'db-owner cookie msg
			     params: params retval: #t)))
	  (match (and res (string-split res))
	    ((retcookie owner-host-port)
	     (values (equal? retcookie cookie) owner-host-port))
	    (else (values #f #f))))
	(values #f -1))))

;; called in ulex-handler to dispatch work, called on the workers side
;;     calls (proc params data)
;;     returns result with cookie
;;
;; pdat is the info of the caller, used to send the result data

	  (udat-my-pid     udata) "-"
	  newcnum)))

;; create a tcp listener and return a populated udat struct with
;; my port, address, hostname, pid etc.
;; return #f if fail to find a port to allocate.
;;
;;  does not actually start a server thread
;;
;;  if udata-in is #f create the record
;;  if there is already a serv-listener return the udata
;;
(define (start-server-find-port udata-in #!optional (port 4242)(tries 0))
  (let ((udata (or udata-in (make-udat))))
    (if (udat-serv-listener udata) ;; TODO - add check that the listener is alive and ready?
	udata
	(let ((res (connect-server udata port)))
	  (if res
	      res
	      (begin
		;; (print "Could not connect to " port)
		(if (and (< port  65535)
			 (< tries 10000)) ;; make this number bigger when things are working
		    (start-server-find-port udata (+ port 1)(+ tries 1))
		    #f)))))))


(define (connect-server udata port)
  ;; (tcp-listener-socket LISTENER)(socket-name so)
  ;; sockaddr-address, sockaddr-port, sockaddr->string
  (let* ((tlsn (handle-exceptions
		   exn
		   #f ;; NB// NEED BETTER HANDLING HERE ASAP
		 (tcp-listen port 1000 #f))) ;; (tcp-listen TCPPORT [BACKLOG [HOST]])
	 (addr (get-my-best-address))) ;; (hostinfo-addresses (host-information (current-hostname)))
    (if tlsn
	(begin
	  (udat-my-address-set!    udata addr)
	  (udat-my-port-set!       udata port)
	  (udat-my-hostname-set!   udata (get-host-name))
	  (udat-serv-listener-set! udata tlsn)
	  udata)
	#f)))

(define (get-peer-dat udata host-port #!optional (hostname #f)(pid #f))
  (let* ((pdat (or (udat-get-peer udata host-port)
		   (handle-exceptions ;; ERROR - MAKE THIS EXCEPTION HANDLER MORE SPECIFIC
		    exn
		    #f
		    (let ((npdat (make-peer addr-port: host-port)))

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

#FIG 3.2  Produced by xfig version 3.2.5-alpha5
Landscape
Center
Inches
Letter  
100.00
Single
-2
1200 2
0 32 #c5b696
0 33 #eef7fe
0 34 #dbcaa5
0 35 #404040
0 36 #808080
0 37 #bfbfbf
0 38 #dfdfdf
0 39 #8d8e8d
0 40 #a9a9a9
0 41 #555555
0 42 #c6c2c6
0 43 #565151
0 44 #8d8d8d
0 45 #d6d6d6
0 46 #84807d
0 47 #d1d1d1
0 48 #3a3a3a
0 49 #4573a9
0 50 #adadad
0 51 #7b79a4
0 52 #444444
0 53 #73758b
0 54 #f6f6f6
0 55 #414541
0 56 #635dcd
0 57 #bdbdbd
0 58 #515151
0 59 #e6e2e6
0 60 #000049
0 61 #797979
0 62 #303430
0 63 #414141
0 64 #c6b595
6 11775 7350 12750 9000
6 11775 7350 12750 8775
5 1 0 1 -1 -1 0 0 -1 0.000 0 1 0 0 12240.000 7050.000 11790 7650 12240 7800 12690 7650
5 1 0 1 -1 -1 0 0 -1 0.000 0 1 0 0 12240.000 7950.000 11790 8550 12240 8700 12690 8550
1 2 0 1 -1 -1 0 0 -1 0.000 1 0.0000 12240 7500 450 150 11790 7350 12690 7650
2 1 0 1 -1 -1 0 0 -1 0.000 0 0 0 0 0 2
	 12690 7575 12690 8550
2 1 0 1 -1 -1 0 0 -1 0.000 0 0 0 0 0 2
	 11790 7575 11790 8550
4 0 0 50 -1 0 12 0.0000 4 150 210 12075 8250 db\001
-6
4 0 0 50 -1 0 12 0.0000 4 150 690 12000 9000 main.db\001
-6
6 7950 6975 9375 7575
2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
	 7950 6975 9375 6975 9375 7575 7950 7575 7950 6975
4 0 0 50 -1 0 12 0.0000 4 195 1335 8100 7350 send-responses\001
-6
6 450 10950 1425 12600
6 450 10950 1425 12375
5 1 0 1 -1 -1 0 0 -1 0.000 0 1 0 0 915.000 10650.000 465 11250 915 11400 1365 11250
5 1 0 1 -1 -1 0 0 -1 0.000 0 1 0 0 915.000 11550.000 465 12150 915 12300 1365 12150
1 2 0 1 -1 -1 0 0 -1 0.000 1 0.0000 915 11100 450 150 465 10950 1365 11250
2 1 0 1 -1 -1 0 0 -1 0.000 0 0 0 0 0 2
	 1365 11175 1365 12150
2 1 0 1 -1 -1 0 0 -1 0.000 0 0 0 0 0 2
	 465 11175 465 12150
4 0 0 50 -1 0 12 0.0000 4 150 210 750 11850 db\001
-6
4 0 0 50 -1 0 12 0.0000 4 150 690 675 12600 main.db\001
-6
6 4800 15525 5775 16950
5 1 0 1 -1 -1 0 0 -1 0.000 0 1 0 0 5265.000 15225.000 4815 15825 5265 15975 5715 15825
5 1 0 1 -1 -1 0 0 -1 0.000 0 1 0 0 5265.000 16125.000 4815 16725 5265 16875 5715 16725
1 2 0 1 -1 -1 0 0 -1 0.000 1 0.0000 5265 15675 450 150 4815 15525 5715 15825
2 1 0 1 -1 -1 0 0 -1 0.000 0 0 0 0 0 2
	 5715 15750 5715 16725
2 1 0 1 -1 -1 0 0 -1 0.000 0 0 0 0 0 2
	 4815 15750 4815 16725
4 0 0 50 -1 0 12 0.0000 4 150 210 5100 16425 db\001
-6
6 8025 12750 9000 14175
5 1 0 1 -1 -1 0 0 -1 0.000 0 1 0 0 8490.000 12450.000 8040 13050 8490 13200 8940 13050
5 1 0 1 -1 -1 0 0 -1 0.000 0 1 0 0 8490.000 13350.000 8040 13950 8490 14100 8940 13950
1 2 0 1 -1 -1 0 0 -1 0.000 1 0.0000 8490 12900 450 150 8040 12750 8940 13050
2 1 0 1 -1 -1 0 0 -1 0.000 0 0 0 0 0 2
	 8940 12975 8940 13950
2 1 0 1 -1 -1 0 0 -1 0.000 0 0 0 0 0 2
	 8040 12975 8040 13950
4 0 0 50 -1 0 12 0.0000 4 150 210 8325 13650 db\001
-6
1 3 0 1 0 7 50 -1 -1 0.000 1 0.0000 2325 12675 645 645 2325 12675 2850 13050
1 3 0 1 0 7 50 -1 -1 0.000 1 0.0000 6075 11025 645 645 6075 11025 6600 11400
1 3 0 1 0 7 50 -1 -1 0.000 1 0.0000 6600 13950 645 645 6600 13950 7125 14325
1 3 0 1 0 7 50 -1 -1 0.000 1 0.0000 3750 16650 645 645 3750 16650 4275 17025
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2
	0 0 1.00 60.00 120.00
	 2625 2250 7575 2250
2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
	 7575 1875 9525 1875 9525 3750 7575 3750 7575 1875
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2
	0 0 1.00 60.00 120.00
	 8250 2400 8250 4275
2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
	 7575 4275 9525 4275 9525 5100 7575 5100 7575 4275
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2
	0 0 1.00 60.00 120.00
	 7575 4650 2625 4650
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 3
	0 0 1.00 60.00 120.00
	 9525 4650 10275 4650 10275 5175
2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
	 9975 5175 10650 5175 10650 6975 9975 6975 9975 5175
2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
	 9975 6975 10650 6975 10650 7575 9975 7575 9975 6975
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 3
	0 0 1.00 60.00 120.00
	 10650 7125 12000 7125 12150 7350
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 3
	0 0 1.00 60.00 120.00
	 11925 7350 11850 7200 10650 7200
2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
	 675 1875 2625 1875 2625 5025 675 5025 675 1875
2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
	 675 5025 2625 5025 2625 6000 675 6000 675 5025
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2
	0 0 1.00 60.00 120.00
	 1575 4800 1575 5325
2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
	 3375 5100 5250 5100 5250 6300 3375 6300 3375 5100
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 4
	0 0 1.00 60.00 120.00
	 7950 7275 6525 7275 6525 5700 5250 5700
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2
	0 0 1.00 60.00 120.00
	 3375 5700 2625 5700
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2
	0 0 1.00 60.00 120.00
	 1575 6000 1575 6825
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2
	0 0 1.00 60.00 120.00
	 9975 7275 9375 7275
2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
	 450 1500 5775 1500 5775 7800 450 7800 450 1500
2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
	 6075 1500 11325 1500 11325 7800 6075 7800 6075 1500
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
	 5925 375 5925 9675
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
	 1800 12225 1275 11775
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
	 5550 11325 2850 12375
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
	 5925 13875 2925 12900
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
	 3525 16050 2625 13275
2 1 0 1 12 7 50 -1 -1 0.000 0 0 -1 0 0 2
	 7200 13800 8025 13500
2 1 0 1 1 7 50 -1 -1 0.000 0 0 -1 0 0 2
	 4350 16425 4800 16200
2 1 0 1 12 7 50 -1 -1 0.000 0 0 -1 0 0 2
	 6225 11700 6525 13350
2 1 0 1 1 7 50 -1 -1 0.000 0 0 -1 0 0 2
	 5850 11700 3975 16050
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
	 4350 16575 4800 16350
4 0 0 50 -1 0 12 0.0000 4 150 990 7575 1800 ulex:launch\001
4 0 0 50 -1 0 12 0.0000 4 150 720 750 1800 ulex:call\001
4 0 0 50 -1 0 12 0.0000 4 195 1230 1200 2325 send-message\001
4 0 0 50 -1 0 12 0.0000 4 195 1470 7650 2325 receive-message\001
4 0 0 50 -1 0 12 0.0000 4 195 1410 7725 4575 std-peer-handler\001
4 0 0 50 -1 0 12 0.0000 4 195 2160 3600 4500 '(#t "info msg" <cookie>)\001
4 0 0 50 -1 0 12 0.0000 4 150 450 10725 5625 work\001
4 0 0 50 -1 0 12 0.0000 4 150 525 10725 5880 queue\001
4 0 0 50 -1 0 12 0.0000 4 150 1290 750 5775 mailbox - waits\001
4 0 0 50 -1 0 12 0.0000 4 150 990 3525 5400 ulex:launch\001
4 0 0 50 -1 0 12 0.0000 4 195 1470 3525 6000 receive-message\001
4 0 0 50 -1 0 12 0.0000 4 150 480 1200 6975 result\001
4 0 0 50 -1 0 12 0.0000 4 165 1185 1500 13500 megatest -run\001
4 0 0 50 -1 0 12 0.0000 4 150 900 6375 11925 dashboard\001
4 0 0 50 -1 0 12 0.0000 4 165 1590 6375 14925 megatest -execute\001
4 0 0 50 -1 0 12 0.0000 4 195 2040 3150 17625 megatest -remove-keep\001
4 0 0 50 -1 0 12 0.0000 4 150 375 8250 14400 1.db\001
4 0 0 50 -1 0 12 0.0000 4 150 375 5025 17175 2.db\001