ADDED build-assist/README Index: build-assist/README ================================================================== --- /dev/null +++ build-assist/README @@ -0,0 +1,28 @@ +Here is how I like to install chicken for building Megatest. + +This guide assumes you have the Megatest fossil and are in the build-assist directory and +that you have the opensrc fossil with uv synced: + +fossil clone https://www.kiatoa.com/fossils/megatest +fossil clone https://www.kiatoa.com/fossils/opensrc;cd opensrc;fossil uv sync + +Make a build directory and go to it: + +mkdir build;cd build + +Make a destination directory and set PREFIX + +export PREFIX=/opt/chicken/5.3.0; mkdir -p $PREFIX + +Get chicken: + +wget https://code.call-cc.org/releases/5.3.0/chicken-5.3.0.tar.gz + +Extract, build, and install chicken: + +tar xf chicken-5.3.0.tar.gz; cd chicken-5.3.0; make PLATFORM=linux PREFIX=$PREFIX install; cd .. + +Install all needed eggs. +for egg in $(cat ../ck5-egg.list);do echo $egg;ck5 chicken-install $egg;done + +Now run the script ../iup-compile.sh for remaining instructions Index: build-assist/ck5 ================================================================== --- build-assist/ck5 +++ build-assist/ck5 @@ -1,9 +1,17 @@ #!/bin/bash -export PATH=/home/matt/data/buildall/ck5.2/bin:$PATH -if [[ -z /home/matt/data/buildall/ck5.2/lib:/home/matt/data/buildall/ck5.2/lib64 ]];then - export LD_LIBRARY_PATH=/home/matt/data/buildall/ck5.2/lib:/home/matt/data/buildall/ck5.2/lib64:$LD_LIBRARY_PATH +# /opt/chicken/5.3.0 +# WHICHCKVER=5.1.0_WW45 +WHICHCKVER=5.3.0 + +BASEDIR=/opt/chicken/$WHICHCKVER +export PATH="$BASEDIR/bin:$PATH" + +NEW_LD_LIBRARY_PATH="$BASEDIR/lib:$BASEDIR/lib64" +if [[ -z "$LD_LIBRARY_PATH" ]];then + export LD_LIBRARY_PATH=$NEW_LD_LIBRARY_PATH else - export LD_LIBRARY_PATH=/home/matt/data/buildall/ck5.2/lib:/home/matt/data/buildall/ck5.2/lib64 + export LD_LIBRARY_PATH="$NEW_LD_LIBRARY_PATH:$LD_LIBRARY_PATH" fi -export CHICKEN_DOC_PAGER=cat + exec "$@" + Index: build-assist/ck5-eggs.list ================================================================== --- build-assist/ck5-eggs.list +++ build-assist/ck5-eggs.list @@ -1,5 +1,6 @@ +csm address-info ansi-escape-sequences apropos base64 crypt ADDED build-assist/installing-nng Index: build-assist/installing-nng ================================================================== --- /dev/null +++ build-assist/installing-nng @@ -0,0 +1,23 @@ +wget https://github.com/nanomsg/nng/archive/refs/tags/v1.5.2.tar.gz +tar xf v1.5.2.tar.gz +cd nng-1.5.2 +mkdir build +cd build +make +sudo make install +vi CMakeCache.txt + +Change OFF to ON for shared libraries: + +//Build shared library +BUILD_SHARED_LIBS:BOOL=ON + +make +sudo make install +sudo ldconfig + +chicken-install nng +-or- +git clone https://gitlab.com/ariSun/chicken-nng.git +cd chicken-ngg;chicken-install + Index: build-assist/iup-compile.sh ================================================================== --- build-assist/iup-compile.sh +++ build-assist/iup-compile.sh @@ -4,11 +4,16 @@ fi echo "Put iup, im and cd .a and .so files in PREFIX/lib" echo " 1. get opensrc fossil from https://www.kiatoa.com/fossils/opensrc" echo " 2. list the unversioned files and export the cd, im and iup lib for your kernel (try uname -a for the kernel number) 4.15 ==> 415_64" +echo ' for x in $(fossil uv list | grep 415| awk ''{print $6}'');do targ=$(echo $x|cut -d/ -f3); fossil uv export $x $targ; done' echo " 3. untar iup, im and cp tars into a clean working dir and then copy:" +echo " find . -name \*.a -print -exec cp {} $PREFIX/lib \;" +echo " find . -name \*.so -print -exec cp {} $PREFIX/lib \;" +echo " rsync -av include/ $PREFIX/include/" +echo " or (depending on versions and what you see in the iup tars - they seem to vary" echo " cp *.a *.so $PREFIX/lib" echo " cp include/*.h $PREFIX/include" echo " 4. run the chicken-install like this:" echo "If you use a wrapper (e.g. ck5) to create the chicken environment:" Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -42,10 +42,11 @@ (declare (uses subrunmod)) (declare (uses tree)) (declare (uses vgmod)) (declare (uses testsmod)) (declare (uses tasksmod)) +(declare (uses dbi)) ;; needed for configf scripts, scheme etc. ;; (declare (uses apimod.import)) ;; (declare (uses debugprint.import)) ;; (declare (uses mtargs.import)) @@ -89,10 +90,11 @@ (prefix iup iup:) canvas-draw canvas-draw-iup (prefix sqlite3 sqlite3:) + (prefix dbi dbi:) srfi-1 regex regex-case srfi-69 typed-records sparse-vectors format @@ -2842,11 +2844,11 @@ (dashboard:runs-horizontal-slider runs-dat)))) controls )) (views-cfgdat (common:load-views-config)) (additional-tabnames '()) - (tab-start-num 5) ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW + (tab-start-num 6) ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW ;; (data (dboard:tabdat-init (make-d:data))) (additional-views ;; process views-dat (let ((tab-num tab-start-num) (result '())) (for-each @@ -2889,18 +2891,21 @@ runs-view ;; (make-runs-view commondat runs2-dat 2) (dashboard:runs-summary commondat onerun-dat tab-num: 2) (dashboard:run-controls commondat runcontrols-dat tab-num: 3) (dashboard:run-times commondat runtimes-dat tab-num: 4) + (iup:vbox (iup:button "Pushme")) ;; tab 5 additional-views))) ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) (iup:attribute-set! tabs "TABTITLE0" "Summary") (iup:attribute-set! tabs "TABTITLE1" "Runs") ;; (iup:attribute-set! tabs "TABTITLE2" "Runs2") (iup:attribute-set! tabs "TABTITLE2" "Run Summary") (iup:attribute-set! tabs "TABTITLE3" "Run Control") (iup:attribute-set! tabs "TABTITLE4" "Run Times") + (iup:attribute-set! tabs "TABTITLE5" "Sys Status") + ;; (iup:attribute-set! tabs "TABTITLE3" "New View") ;; (iup:attribute-set! tabs "TABTITLE4" "Run Control") ;; set the tab names for user added tabs (for-each Index: dbi.scm ================================================================== --- dbi.scm +++ dbi.scm @@ -17,7 +17,8 @@ ;; along with Megatest. If not, see . ;;====================================================================== (declare (unit dbi)) +(declare (uses autoload)) (include "dbi/dbi.scm") Index: dbmod.scm ================================================================== --- dbmod.scm +++ dbmod.scm @@ -44,15 +44,16 @@ db:get-ddb db:open-dbdat db:open-run-db db:open-inmem-db db:setup -db:get-main-lock +;; db:get-main-lock db:with-lock-db db:get-iam-server-lock db:get-locker db:take-lock +db:steal-lock-db db:release-lock db:general-sqlite-error-dump db:first-result-default db:generic-error-printout db:with-db @@ -511,11 +512,11 @@ ;; The lockname is the filename (can have many to one, run-id to fname ;;====================================================================== ;; only use for main.db - need to re-write some of this :( ;; -(define (db:get-main-lock dbfile) +#;(define (db:get-main-lock dbfile) (db:with-lock-db dbfile (lambda (dbh dbfile) (db:get-iam-server-lock dbh dbfile)))) (define (db:with-lock-db dbfile proc) @@ -524,34 +525,39 @@ ;; (sqlite3:finalize! dbh) res)) ;; called before db is open? ;; -(define (db:get-iam-server-lock dbh dbfname) +(define (db:get-iam-server-lock dbh dbfname port) (sqlite3:with-transaction dbh (lambda () (let* ((locker (db:get-locker dbh dbfname))) (if locker - #f - (db:take-lock dbh dbfname)))))) + locker + (db:take-lock dbh dbfname port)))))) ;; (exn sqlite3) (define (db:get-locker dbh dbfname) (condition-case - (sqlite3:first-row dbh "SELECT owner_pid,owner_host,event_time FROM locks WHERE lockname=?;" dbfname) + (sqlite3:first-row dbh "SELECT owner_pid,owner_host,owner_port,event_time FROM locks WHERE lockname=?;" dbfname) (exn (sqlite3) #f))) ;; should never fail because it is run in a transaction with a test for the lock ;; -(define (db:take-lock dbh dbfname) +(define (db:take-lock dbh dbfname port) ;; (condition-case ;; (begin - (sqlite3:execute dbh "INSERT INTO locks (lockname,owner_pid,owner_host) VALUES (?,?,?);" dbfname (current-process-id) (get-host-name)) + (sqlite3:execute dbh "INSERT INTO locks (lockname,owner_pid,owner_host,owner_port) VALUES (?,?,?,?);" dbfname (current-process-id) (get-host-name) port) ;; #t) ;; (exn (sqlite3) #f))) #t) + +(define (db:steal-lock-db dbh dbfname port) + (sqlite3:execute dbh "DELETE FROM locks WHERE lockname=?;" dbfname) + (sqlite3:execute dbh "INSERT INTO locks (lockname,owner_pid,owner_host,owner_port) VALUES (?,?,?,?);" dbfname (current-process-id) (get-host-name) port) + #t) (define (db:release-lock dbh dbfname) (sqlite3:execute dbh "DELETE FROM locks WHERE lockname=?;" dbfname)) ;;====================================================================== @@ -1515,10 +1521,11 @@ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS locks (id INTEGER PRIMARY KEY, lockname TEXT, owner_pid INTEGER, owner_host TEXT, + owner_port TEXT, event_time TIMESTAMP DEFAULT (strftime('%s','now')), CONSTRAINT lock_constraint UNIQUE (lockname));") ;; maps to *srvpktspec* from http-transportmod (sqlite3:execute db "CREATE TABLE IF NOT EXISTS servers Index: rmtmod.scm ================================================================== --- rmtmod.scm +++ rmtmod.scm @@ -299,11 +299,12 @@ ))) ;;====================================================================== ;; FOR DEBUGGING SET TO #t -(define *localmode* #t) +;; (define *localmode* #t) +(define *localmode* #f) (define *dbstruct* (make-dbr:dbstruct)) ;; Defaults to current area ;; (define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) @@ -1487,12 +1488,16 @@ ;; do a final sync here (debug:print-info 0 *default-log-port* "Doing final sync for "apath" "dbfile" at "(current-seconds)) (db:sync-inmem->disk *dbstruct-db* apath dbfile force-sync: #t) ;; let's finalize here (debug:print-info 0 *default-log-port* "Finalizing db and inmem") - (sqlite3:finalize! db) - (sqlite3:finalize! inmem) + (if (sqlite3:database? db) + (sqlite3:finalize! db) + (debug:print-info 0 *default-log-port* "in rmt:server-shutdown, db is not a database, not finalizing...")) + (if (sqlite3:database? inmem) + (sqlite3:finalize! inmem) + (debug:print-info 0 *default-log-port* "in rmt:server-shutdown, inmem is not a database, not finalizing...")) (debug:print-info 0 *default-log-port* "Finalizing db and inmem complete") (if am-server (if (string-match ".*/main.db$" dbfile) (let ((pkt-file (conc (get-pkts-dir *toppath*) "/" (servdat-uuid *server-info*) @@ -1816,13 +1821,25 @@ ;; NEW SERVER METHOD ;;====================================================================== ;; only use for main.db - need to re-write some of this :( ;; -(define (get-lock-db sdat dbfile) - (let* ((dbh (db:open-run-db dbfile db:initialize-db)) - (res (db:get-iam-server-lock dbh dbfile))) +(define (get-lock-db sdat dbfile port) + (let* ((dbh (db:open-run-db dbfile db:initialize-db)) ;; open-run-db creates a standard db with schema used by all situations + (res (db:get-iam-server-lock dbh dbfile port))) + ;; res => list then already locked, check server is responsive + ;; => #t then sucessfully got the lock + ;; => #f reserved for future use as to indicate something went wrong + (match res + ((owner_pid owner_host owner_port event_time) + (if (server-ready? owner_host owner_port "abc") + #f + (begin + (debug:print 0 *default-log-port* "WARNING: stale lock - have to steal it. This may fail.") + (db:steal-lock-db dbh dbfile port)))) + (#t #t) ;; placeholder so that we don't touch res if it is #t + (else (set! res #f))) (sqlite3:finalize! dbh) res)) (define (register-server pkts-dir pkt-spec host port servkey ipaddr dbpath) @@ -1918,10 +1935,29 @@ (let* ((spkt (car tail))) (loop (cdr tail) (if (equal? dbpath (alist-ref 'dbpath spkt)) (cons spkt res) res)))))) + +(define (remove-pkts-if-not-alive serv-pkts) + (filter (lambda (pkt) + (let* ((host (alist-ref 'host pkt)) + (port (alist-ref 'port pkt)) + (key (alist-ref 'servkey pkt)) + (pktz (alist-ref 'Z pkt)) + (res (handle-exceptions + exn + #f + (server-ready? host port key)))) + (if res + res + (let* ((pktsdir (get-pkts-dir *toppath*)) + (pktpath (conc pktsdir"/"pktz".pkt"))) + (debug:print 0 *default-log-port* "WARNING: pkt with no server "pktpath) + (delete-file* pktpath) + #f)))) + serv-pkts)) ;; from viable servers get one that is alive and ready ;; (define (get-the-server apath serv-pkts) (let loop ((tail serv-pkts)) @@ -2005,32 +2041,39 @@ (servdat-host sdat) db-file)) ;; (set! *my-signature* (servdat-uuid sdat)) ;; replace with Z, no, stick with proper key ;; now read pkts and see if we are a contender (let* ((all-pkts (get-all-server-pkts pkts-dir *srvpktspec*)) (viables (get-viable-servers all-pkts db-file)) - (best-srv (get-best-candidate viables db-file)) - (best-srv-key (if best-srv (alist-ref 'servkey best-srv) #f))) - (debug:print 0 *default-log-port* "best-srv-key: "best-srv-key", server-key: "server-key) + (alive (remove-pkts-if-not-alive viables)) + (best-srv (get-best-candidate alive db-file)) + (best-srv-key (if best-srv (alist-ref 'servkey best-srv) #f)) + (i-am-srv (equal? best-srv-key server-key)) + (delete-pkt (lambda () + (let* ((pktfile (conc (get-pkts-dir *toppath*) + "/" (servdat-uuid *server-info*) + ".pkt"))) + (debug:print-info 0 *default-log-port* "Attempting to remove bogus pkt file "pktfile) + (delete-file* pktfile))))) ;; remove immediately instead of waiting for on-exit + (debug:print 0 *default-log-port* "best-srv-key: "best-srv-key", server-key: "server-key", i-am-srv: "i-am-srv) ;; am I the best-srv, compare server-keys to know - (if (equal? best-srv-key server-key) - (if (get-lock-db sdat db-file) ;; (db:get-iam-server-lock *dbstruct-db* *toppath* run-id) + (if i-am-srv + (if (get-lock-db sdat db-file (servdat-port sdat)) ;; (db:get-iam-server-lock *dbstruct-db* *toppath* run-id) (begin (debug:print 0 *default-log-port* "I'm the server!") (servdat-dbfile-set! sdat db-file) (servdat-status-set! sdat 'db-locked)) (begin (debug:print 0 *default-log-port* "I'm not the server, exiting.") (bdat-time-to-exit-set! *bdat* #t) + (delete-pkt) (thread-sleep! 0.2) (exit))) (begin (debug:print 0 *default-log-port* "Keys do not match "best-srv-key", "server-key", exiting.") (bdat-time-to-exit-set! *bdat* #t) - (delete-file* (conc (get-pkts-dir *toppath*) - "/" (servdat-uuid *server-info*) - ".pkt")) ;; remove immediately instead of waiting for on-exit + (delete-pkt) (thread-sleep! 0.2) (exit))) sdat)) (begin ;; sdat not yet contains server info (debug:print-info 0 *default-log-port* "Still waiting, last-sdat=" last-sdat) Index: stml2.scm ================================================================== --- stml2.scm +++ stml2.scm @@ -18,8 +18,10 @@ ;;====================================================================== (declare (unit stml2)) (declare (uses cookie)) +(declare (uses dbi)) +(declare (uses autoload)) (include "stml2/stml2.scm") Index: stml2/formdat.scm ================================================================== --- stml2/formdat.scm +++ stml2/formdat.scm @@ -10,12 +10,11 @@ ;; (declare (unit formdat)) (module formdat * -(import chicken scheme data-structures extras srfi-13 ports ) -(use html-filter) +(import chicken scheme data-structures extras srfi-13 ports html-filter) -(use regex) -(require-extension srfi-69) +(import regex) +(import srfi-69) ) Index: stml2/html-filter.scm ================================================================== --- stml2/html-filter.scm +++ stml2/html-filter.scm @@ -11,11 +11,11 @@ (module html-filter * (import chicken scheme data-structures extras srfi-13 ports ) -(use misc-stml) +(import misc-stml) -(require-extension regex) +(import regex) ;; ) Index: stml2/misc-stml.scm ================================================================== --- stml2/misc-stml.scm +++ stml2/misc-stml.scm @@ -16,9 +16,8 @@ (module misc-stml * (import chicken scheme data-structures extras srfi-13 ports posix) -(use regex (prefix dbi dbi:)) -(use (prefix crypt c:)) -(use (prefix dbi dbi:)) +(import regex (prefix dbi dbi:)) +(import (prefix crypt c:)) ) Index: stml2/rollup-pages.scm ================================================================== --- stml2/rollup-pages.scm +++ stml2/rollup-pages.scm @@ -1,6 +1,6 @@ -(use regex posix srfi-69 srfi-1) +(import regex posix srfi-69 srfi-1) (define extract-rx (regexp "pages\\/(.*)_(view|ctrl).scm")) (define (print-page-wrapper lookup page) (print "(define (pages:" page " session db shared)") Index: stml2/session.scm ================================================================== --- stml2/session.scm +++ stml2/session.scm @@ -11,10 +11,9 @@ (module session * (import chicken scheme data-structures extras srfi-13 ports posix files srfi-1) -(use (prefix dbi dbi:) srfi-69) -(require-extension regex) -(use cookie stmlcommon) ;; (declare (uses cookie)) +(import (prefix dbi dbi:) srfi-69 regex) +(import cookie stmlcommon) ;; (declare (uses cookie)) ) Index: stml2/setup.scm ================================================================== --- stml2/setup.scm +++ stml2/setup.scm @@ -9,13 +9,12 @@ (module setup * (import chicken scheme data-structures extras srfi-13 ports posix) -(uses session misc-stml) +(import session misc-stml) ;; (declare (unit setup))se ;; (declare (uses session)) -(require-extension srfi-69) -(require-extension regex) +(import srfi-69 regex) ) Index: stml2/spiffyserver.scm ================================================================== --- stml2/spiffyserver.scm +++ stml2/spiffyserver.scm @@ -1,8 +1,8 @@ ;; This doesn't work yet ;; -(use spiffy cgi-handler) +(import spiffy cgi-handler) (spiffy-debug-mode #t) (spiffy-file-ext-handlers `(("drcdb" . ,(cgi-handler* "/path/to/drcdb")))) Index: stml2/sqlite3.scm ================================================================== --- stml2/sqlite3.scm +++ stml2/sqlite3.scm @@ -9,11 +9,11 @@ ;; ;; I used this to get a simple interactive sqlite editor on the nokia n800 ;; since I couldn't get sqlite3 to install (for reasons I can't remember). -(use sqlite3) +(import sqlite3) (define args (argv)) (define num-args (length args)) (define dbname #f) Index: stml2/stmlcommon.scm ================================================================== --- stml2/stmlcommon.scm +++ stml2/stmlcommon.scm @@ -13,8 +13,8 @@ (module stmlcommon * (import chicken scheme data-structures extras srfi-13 ports posix) -(use (prefix dbi dbi:) regex (prefix crypt c:) srfi-69) +(import (prefix dbi dbi:) regex (prefix crypt c:) srfi-69) ) Index: stml2/stmlrun.scm ================================================================== --- stml2/stmlrun.scm +++ stml2/stmlrun.scm @@ -11,9 +11,9 @@ ;; (require-extension syntax-case) ;; (declare (run-time-macros)) ;; (include "stmlcommon.scm") -(require-library stml) +(import stml) (stml:main #f) Index: stml2/test.scm ================================================================== --- stml2/test.scm +++ stml2/test.scm @@ -1,8 +1,7 @@ -(use test md5) +(import test md5) -(require-extension sqlite3) (import (prefix sqlite3 sqlite3:)) (require-library dbi) ;; (declare (uses stml)) Index: testsmod.scm ================================================================== --- testsmod.scm +++ testsmod.scm @@ -26,10 +26,11 @@ (declare (uses itemsmod)) (declare (uses rmtmod)) (declare (uses stml2)) (declare (uses dbmod)) (declare (uses tasksmod)) +(declare (uses dbi)) (module testsmod * (import scheme