Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -28,11 +28,11 @@
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 =
+MSRCFILES = adjutant.scm mutils.scm mttop.scm ulex.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
Index: configf.scm
==================================================================
--- configf.scm
+++ configf.scm
@@ -531,12 +531,12 @@
(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 cfdat section varname #!key (default #f))
- (let* ((val (configf:lookup *configdat* section varname))
+(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)
Index: dashboard-tests.scm
==================================================================
--- dashboard-tests.scm
+++ dashboard-tests.scm
@@ -324,12 +324,12 @@
(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 "BGCOLOR")))
- (iup:attribute-set! btn "BGCOLOR" newcolor))))
+ (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)
@@ -358,12 +358,12 @@
(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 "BGCOLOR")))
- (iup:attribute-set! btn "BGCOLOR" newcolor))))
+ (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)
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -1171,13 +1171,14 @@
(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 "BGCOLOR" color)
+ (iup:attribute-set! button "FGCOLOR" color))
(if (not (equal? curr-title buttontxt))
- (iup:attribute-set! button "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)))
@@ -2485,22 +2486,22 @@
(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 "BGCOLOR" sel-color)
- (iup:attribute-set! show "BGCOLOR" nonsel-color)
+ (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 "BGCOLOR" sel-color)
- (iup:attribute-set! hide "BGCOLOR" nonsel-color)
+ (iup:attribute-set! show "FGCOLOR" sel-color)
+ (iup:attribute-set! hide "FGCOLOR" nonsel-color)
(mark-for-update tabdat))))
- (iup:attribute-set! hide "BGCOLOR" sel-color)
- (iup:attribute-set! show "BGCOLOR" nonsel-color)
+ (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)))
)
@@ -2869,10 +2870,11 @@
(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)
Index: http-transport.scm
==================================================================
--- http-transport.scm
+++ http-transport.scm
@@ -576,26 +576,31 @@
(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)
+ (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/" "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)
- (system (conc "sleep 1;mv -f " full-serv-fname " " new-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
+ (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*))))
+ (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)
ADDED mtconfigf/Makefile
Index: mtconfigf/Makefile
==================================================================
--- /dev/null
+++ mtconfigf/Makefile
@@ -0,0 +1,2 @@
+test:
+ env CHICKEN_REPOSITORY=../../../megatest/tmpinstall/eggs/lib/chicken/7 csi -s tests/run.scm
ADDED mtconfigf/mtconfigf.meta
Index: mtconfigf/mtconfigf.meta
==================================================================
--- /dev/null
+++ mtconfigf/mtconfigf.meta
@@ -0,0 +1,20 @@
+(
+; 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."))
ADDED mtconfigf/mtconfigf.scm
Index: mtconfigf/mtconfigf.scm
==================================================================
--- /dev/null
+++ mtconfigf/mtconfigf.scm
@@ -0,0 +1,1170 @@
+;;======================================================================
+;; 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)
+
+)
ADDED mtconfigf/mtconfigf.setup
Index: mtconfigf/mtconfigf.setup
==================================================================
--- /dev/null
+++ mtconfigf/mtconfigf.setup
@@ -0,0 +1,16 @@
+;; 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")
ADDED mtconfigf/tests/run.scm
Index: mtconfigf/tests/run.scm
==================================================================
--- /dev/null
+++ mtconfigf/tests/run.scm
@@ -0,0 +1,48 @@
+(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"))
+
+ )
+
ADDED mtconfigf/tests/test.config
Index: mtconfigf/tests/test.config
==================================================================
--- /dev/null
+++ mtconfigf/tests/test.config
@@ -0,0 +1,3 @@
+[basic]
+key value
+two 2
ADDED mtconfigf/tests/test2.config
Index: mtconfigf/tests/test2.config
==================================================================
--- /dev/null
+++ mtconfigf/tests/test2.config
@@ -0,0 +1,15 @@
+[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}
ADDED mtconfigf/tests/test3.config
Index: mtconfigf/tests/test3.config
==================================================================
--- /dev/null
+++ mtconfigf/tests/test3.config
@@ -0,0 +1,3 @@
+[systemic]
+hello [system echo hello]
+hellouser [system echo hello $USER]
Index: mtut.scm
==================================================================
--- mtut.scm
+++ mtut.scm
@@ -154,10 +154,11 @@
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
@@ -773,11 +774,11 @@
(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 (list runkey runname area area-path reason contour mode-patt) ", ") ")")
+ (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))
@@ -1612,23 +1613,70 @@
;; (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)
+ ((dispatch import rungen process go)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
- (toppath (configf:lookup mtconf "scratchdat" "toppath")))
+ (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)))))
+ ((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))
@@ -1807,46 +1855,52 @@
)
)))
(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)
-
+
+ ((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
Index: ulex.scm
==================================================================
--- ulex.scm
+++ ulex.scm
@@ -17,8 +17,8 @@
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
(declare (unit ulex))
-(declare (uses pkts))
+;;(declare (uses pkts))
(include "ulex/ulex.scm")
ADDED ulex/Makefile
Index: ulex/Makefile
==================================================================
--- /dev/null
+++ ulex/Makefile
@@ -0,0 +1,26 @@
+
+
+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.*
ADDED ulex/example.scm
Index: ulex/example.scm
==================================================================
--- /dev/null
+++ ulex/example.scm
@@ -0,0 +1,201 @@
+;;; 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))))
+
ADDED ulex/netutil/testit.scm
Index: ulex/netutil/testit.scm
==================================================================
--- /dev/null
+++ ulex/netutil/testit.scm
@@ -0,0 +1,6 @@
+
+(use ulex-netutil)
+(use test)
+
+(test #f #t (not (not (member "127.0.0.1" (get-all-ips)))))
+
ADDED ulex/netutil/ulex-netutil.meta
Index: ulex/netutil/ulex-netutil.meta
==================================================================
--- /dev/null
+++ ulex/netutil/ulex-netutil.meta
@@ -0,0 +1,16 @@
+;; -*- 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."))
ADDED ulex/netutil/ulex-netutil.release-info
Index: ulex/netutil/ulex-netutil.release-info
==================================================================
--- /dev/null
+++ ulex/netutil/ulex-netutil.release-info
@@ -0,0 +1,3 @@
+(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")
ADDED ulex/netutil/ulex-netutil.scm
Index: ulex/netutil/ulex-netutil.scm
==================================================================
--- /dev/null
+++ ulex/netutil/ulex-netutil.scm
@@ -0,0 +1,134 @@
+;;; 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?))
+
+)
ADDED ulex/netutil/ulex-netutil.setup
Index: ulex/netutil/ulex-netutil.setup
==================================================================
--- /dev/null
+++ ulex/netutil/ulex-netutil.setup
@@ -0,0 +1,11 @@
+;; 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")
ADDED ulex/portlogger/portlogger.meta
Index: ulex/portlogger/portlogger.meta
==================================================================
--- /dev/null
+++ ulex/portlogger/portlogger.meta
@@ -0,0 +1,16 @@
+;; -*- 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."))
ADDED ulex/portlogger/portlogger.release-info
Index: ulex/portlogger/portlogger.release-info
==================================================================
--- /dev/null
+++ ulex/portlogger/portlogger.release-info
@@ -0,0 +1,3 @@
+(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")
ADDED ulex/portlogger/portlogger.scm
Index: ulex/portlogger/portlogger.scm
==================================================================
--- /dev/null
+++ ulex/portlogger/portlogger.scm
@@ -0,0 +1,167 @@
+;;======================================================================
+;; 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
ADDED ulex/portlogger/portlogger.setup
Index: ulex/portlogger/portlogger.setup
==================================================================
--- /dev/null
+++ ulex/portlogger/portlogger.setup
@@ -0,0 +1,11 @@
+;; 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")
ADDED ulex/portlogger/test.scm
Index: ulex/portlogger/test.scm
==================================================================
--- /dev/null
+++ ulex/portlogger/test.scm
@@ -0,0 +1,25 @@
+(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")
ADDED ulex/run-parallel.sh
Index: ulex/run-parallel.sh
==================================================================
--- /dev/null
+++ ulex/run-parallel.sh
@@ -0,0 +1,12 @@
+#!/bin/bash
+
+CMD=$1
+
+make example
+
+for x in $(seq 1 10);do
+ ./example $CMD 2>&1| tee run$x.log &
+done
+
+wait
+
ADDED ulex/telemetry/telemetry-test-client.scm
Index: ulex/telemetry/telemetry-test-client.scm
==================================================================
--- /dev/null
+++ ulex/telemetry/telemetry-test-client.scm
@@ -0,0 +1,12 @@
+
+(load "telemetry.scm")
+
+(import telemetry)
+
+(print 1)
+(telemetry-open "localhost" 12346)
+(print 2)
+(telemetry-send "goo")
+(print 3)
+(telemetry-send "goo2")
+(print 4)
ADDED ulex/telemetry/telemetry-test-server.scm
Index: ulex/telemetry/telemetry-test-server.scm
==================================================================
--- /dev/null
+++ ulex/telemetry/telemetry-test-server.scm
@@ -0,0 +1,18 @@
+
+(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")
ADDED ulex/telemetry/telemetry.meta
Index: ulex/telemetry/telemetry.meta
==================================================================
--- /dev/null
+++ ulex/telemetry/telemetry.meta
@@ -0,0 +1,21 @@
+;; -*- 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."))
ADDED ulex/telemetry/telemetry.release-info
Index: ulex/telemetry/telemetry.release-info
==================================================================
--- /dev/null
+++ ulex/telemetry/telemetry.release-info
@@ -0,0 +1,3 @@
+(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")
ADDED ulex/telemetry/telemetry.scm
Index: ulex/telemetry/telemetry.scm
==================================================================
--- /dev/null
+++ ulex/telemetry/telemetry.scm
@@ -0,0 +1,124 @@
+
+(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)
+
+ )))) )
+
+
+ )
ADDED ulex/telemetry/telemetry.setup
Index: ulex/telemetry/telemetry.setup
==================================================================
--- /dev/null
+++ ulex/telemetry/telemetry.setup
@@ -0,0 +1,11 @@
+;; 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")
ADDED ulex/test-script.scm
Index: ulex/test-script.scm
==================================================================
--- /dev/null
+++ ulex/test-script.scm
@@ -0,0 +1,17 @@
+
+(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 '()))
ADDED ulex/tests/faux-mt-callspec.scm
Index: ulex/tests/faux-mt-callspec.scm
==================================================================
--- /dev/null
+++ ulex/tests/faux-mt-callspec.scm
@@ -0,0 +1,54 @@
+(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")
+
+
+
ADDED ulex/tests/mt-spec.sexpr
Index: ulex/tests/mt-spec.sexpr
==================================================================
--- /dev/null
+++ ulex/tests/mt-spec.sexpr
@@ -0,0 +1,28 @@
+(
+ (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=?")
+ )
+ )
+
+ )
+
ADDED ulex/tests/run.scm
Index: ulex/tests/run.scm
==================================================================
--- /dev/null
+++ ulex/tests/run.scm
@@ -0,0 +1,190 @@
+(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")
+;; ;
ADDED ulex/ulex-netutils.scm
Index: ulex/ulex-netutils.scm
==================================================================
--- /dev/null
+++ ulex/ulex-netutils.scm
@@ -0,0 +1,109 @@
+;;======================================================================
+;; 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?))
+
+)
ADDED ulex/ulex.meta
Index: ulex/ulex.meta
==================================================================
--- /dev/null
+++ ulex/ulex.meta
@@ -0,0 +1,21 @@
+;; -*- 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."))
ADDED ulex/ulex.release-info
Index: ulex/ulex.release-info
==================================================================
--- /dev/null
+++ ulex/ulex.release-info
@@ -0,0 +1,3 @@
+(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")
Index: ulex/ulex.scm
==================================================================
--- ulex/ulex.scm
+++ ulex/ulex.scm
@@ -124,11 +124,11 @@
;; 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)
+(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
@@ -149,14 +149,18 @@
(if success
udata
(begin
(print "Found unreachable captain at " ipaddr ":" port ", removing pkt")
(remove-captain-pkt udata captn)
- (find-or-setup-captain udata))))
- (begin
- (setup-as-captain udata) ;; this saves the thread to captain-thread and starts the thread
- (find-or-setup-captain udata)))))))
+ (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
@@ -540,31 +544,40 @@
;; return #f if fail to find a port to allocate.
;;
;; 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))
+(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
- (handle-exceptions
- exn
- (if (< port 65535)
- (start-server-find-port udata (+ port 1))
- #f)
- (connect-server udata port)))))
+ (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 (tcp-listen port 1000 #f)) ;; (tcp-listen TCPPORT [BACKLOG [HOST]])
+ (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)))
- (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))
+ (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
ADDED ulex/ulex.setup
Index: ulex/ulex.setup
==================================================================
--- /dev/null
+++ ulex/ulex.setup
@@ -0,0 +1,11 @@
+;; 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")
ADDED ulex/ulex_europaeus-branch.jpg
Index: ulex/ulex_europaeus-branch.jpg
==================================================================
--- /dev/null
+++ ulex/ulex_europaeus-branch.jpg
cannot compute difference between binary files
ADDED ulex/write-cycle.fig
Index: ulex/write-cycle.fig
==================================================================
--- /dev/null
+++ ulex/write-cycle.fig
@@ -0,0 +1,186 @@
+#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