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 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 . +;; +;;====================================================================== + +;; 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] ADDED ulex/Makefile Index: ulex/Makefile ================================================================== --- /dev/null +++ ulex/Makefile @@ -0,0 +1,25 @@ + + +all : example + +ulex.so : ulex.scm telemetry/telemetry.so netutil/ulex-netutil.so portlogger/portlogger.so + 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/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/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,187 @@ +(use test + (prefix sqlite3 sqlite3:) + posix + ;; ulex-netutil rpc + pkts + mailbox + hostinfo) + +;; (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*))) + +(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 +;; #include +;; #include +;; #include + +(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 @@ -369,11 +373,11 @@ (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. + ;; (ip->strin g(car (filter (lambda (x) ;; take any but 127. ;; (not (eq? (u8vector-ref x 0) 127))) ;; all-my-addresses)))) ))) @@ -540,31 +544,41 @@ ;; 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))) + (or res + (begin + ;; (print "Could not connect to " port) + (if (and (< port 65535) + (< tries 5000)) ;; 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 + (begin + ;; (print "unable to connect to " port ", exn=" exn) + #f) + (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" )\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