Changes In Branch v2.001 Through [c7197c92dd] Excluding Merge-Ins
This is equivalent to a diff from 3ebb15bd95 to c7197c92dd
2021-12-18
| ||
05:45 | WIP - doesn't compile check-in: 9607b06dff user: matt tags: v2.001 | |
2021-12-14
| ||
20:05 | Mostly got unit tests working again. check-in: c7197c92dd user: matt tags: v2.001 | |
2021-12-13
| ||
19:56 | Fixed bunch of issues with main.db server startup. check-in: c423bc098e user: matt tags: v2.001 | |
2021-12-01
| ||
19:25 | Start of v2.0 (again) check-in: 35ec63886f user: matt tags: v2.001 | |
2021-11-29
| ||
18:41 | Corrected - but not quite - the calls to get-inmem Leaf check-in: 3ebb15bd95 user: matt tags: v1.6584-nanomsg | |
09:38 | wip check-in: 31c178ba40 user: matt tags: v1.6584-nanomsg | |
Modified apimod.scm from [e18f34d37e] to [90c616c280].
︙ | ︙ | |||
202 203 204 205 206 207 208 209 210 211 212 213 214 215 | ((get-keys-write) (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl ;; SERVERS ;; ((start-server) (apply server:kind-run params)) ((kill-server) (set! *server-run* #f)) ((get-server) (api:start-server dbstruct params)) ((register-server) (apply db:register-server dbstruct params) );; dbstruct host port servkey pid ipaddr dbpath) ((deregister-server) (apply db:deregister-server dbstruct params) );; dbstruct host port servkey pid ipaddr dbpath) ((get-count-servers) (apply db:get-count-servers dbstruct params)) ;; TESTS ;;((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params)) | > | 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 | ((get-keys-write) (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl ;; SERVERS ;; ((start-server) (apply server:kind-run params)) ((kill-server) (set! *server-run* #f)) ((get-server) (api:start-server dbstruct params)) ((get-server-info) (apply db:get-server-info dbstruct params)) ((register-server) (apply db:register-server dbstruct params) );; dbstruct host port servkey pid ipaddr dbpath) ((deregister-server) (apply db:deregister-server dbstruct params) );; dbstruct host port servkey pid ipaddr dbpath) ((get-count-servers) (apply db:get-count-servers dbstruct params)) ;; TESTS ;;((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params)) |
︙ | ︙ |
Added build-assist/README version [d108fc0f5b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 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 |
Modified build-assist/ck5 from [a0370c68ea] to [e0bdd3a902].
1 | #!/bin/bash | > > > | > > | > > | | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | #!/bin/bash # /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="$NEW_LD_LIBRARY_PATH:$LD_LIBRARY_PATH" fi exec "$@" |
Modified build-assist/ck5-eggs.list from [4ccb4f5090] to [50ec309d57].
1 2 3 4 5 6 7 | address-info ansi-escape-sequences apropos base64 crypt csv-abnf directory-utils | > | 1 2 3 4 5 6 7 8 | csm address-info ansi-escape-sequences apropos base64 crypt csv-abnf directory-utils |
︙ | ︙ |
Added build-assist/installing-nng version [9ef49d4af4].
> > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 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 |
Modified build-assist/iup-compile.sh from [a1231c7291] to [f2fe37f920].
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | if [[ -z $PREFIX ]];then echo "PREFIX required" exit 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 " 3. untar iup, im and cp tars into a clean working dir and then copy:" 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:" echo "CSC_OPTIONS=\"-I$PREFIX/include -I$PREFIX/include/im -I$PREFIX/include/cd -I$PREFIX/include/iup -L$PREFIX/lib -C -std=gnu99\" ck5 chicken-install iup -feature disable-iup-matrixex" echo "else:" | > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | if [[ -z $PREFIX ]];then echo "PREFIX required" exit 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:" echo "CSC_OPTIONS=\"-I$PREFIX/include -I$PREFIX/include/im -I$PREFIX/include/cd -I$PREFIX/include/iup -L$PREFIX/lib -C -std=gnu99\" ck5 chicken-install iup -feature disable-iup-matrixex" echo "else:" |
︙ | ︙ |
Modified dashboard.scm from [733ea55f33] to [955f1d46eb].
︙ | ︙ | |||
40 41 42 43 44 45 46 47 48 49 50 51 52 53 | (declare (uses runsmod)) (declare (uses rmtmod)) (declare (uses subrunmod)) (declare (uses tree)) (declare (uses vgmod)) (declare (uses testsmod)) (declare (uses tasksmod)) ;; needed for configf scripts, scheme etc. ;; (declare (uses apimod.import)) ;; (declare (uses debugprint.import)) ;; (declare (uses mtargs.import)) ;; (declare (uses commonmod.import)) ;; (declare (uses configfmod.import)) | > | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 | (declare (uses runsmod)) (declare (uses rmtmod)) (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)) ;; (declare (uses commonmod.import)) ;; (declare (uses configfmod.import)) |
︙ | ︙ | |||
87 88 89 90 91 92 93 94 95 96 97 98 99 100 | chicken.time chicken.time.posix (prefix iup iup:) canvas-draw canvas-draw-iup (prefix sqlite3 sqlite3:) srfi-1 regex regex-case srfi-69 typed-records sparse-vectors format srfi-4 srfi-14 | > | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 | chicken.time chicken.time.posix (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 srfi-4 srfi-14 |
︙ | ︙ | |||
2840 2841 2842 2843 2844 2845 2846 | (apply iup:hbox (reverse hdrlst)) (apply iup:hbox (reverse bdylst)) (dashboard:runs-horizontal-slider runs-dat)))) controls )) (views-cfgdat (common:load-views-config)) (additional-tabnames '()) | | | 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 | (apply iup:hbox (reverse hdrlst)) (apply iup:hbox (reverse bdylst)) (dashboard:runs-horizontal-slider runs-dat)))) controls )) (views-cfgdat (common:load-views-config)) (additional-tabnames '()) (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 (lambda (view-name) (debug:print 0 *default-log-port* "Adding view " view-name) |
︙ | ︙ | |||
2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 | "tabchangepos")) (dashboard:summary commondat stats-dat tab-num: 0) 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) 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 "TABTITLE3" "New View") ;; (iup:attribute-set! tabs "TABTITLE4" "Run Control") ;; set the tab names for user added tabs (for-each (lambda (tab-info) (iup:attribute-set! tabs (conc "TABTITLE" (car tab-info)) (cdr tab-info))) | > > > | 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 | "tabchangepos")) (dashboard:summary commondat stats-dat tab-num: 0) 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 (lambda (tab-info) (iup:attribute-set! tabs (conc "TABTITLE" (car tab-info)) (cdr tab-info))) |
︙ | ︙ |
Modified dbi.scm from [3f996117f2] to [b3324417ec].
︙ | ︙ | |||
15 16 17 18 19 20 21 22 23 | ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit dbi)) (include "dbi/dbi.scm") | > | 15 16 17 18 19 20 21 22 23 24 | ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit dbi)) (declare (uses autoload)) (include "dbi/dbi.scm") |
Modified dbmod.scm from [7cd57dd118] to [ddeeddaa42].
︙ | ︙ | |||
42 43 44 45 46 47 48 | db:get-dbdat db:get-inmem db:get-ddb db:open-dbdat db:open-run-db db:open-inmem-db db:setup | | > | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 | db:get-dbdat db:get-inmem db:get-ddb db:open-dbdat db:open-run-db db:open-inmem-db db:setup ;; 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 db:set-sync db:get-last-update-time |
︙ | ︙ | |||
509 510 511 512 513 514 515 | ;; NOTE: ;; These operate directly on the disk file, NOT on the inmemory db ;; 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 :( ;; | | | < > | | | | > > > > > | 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 | ;; NOTE: ;; These operate directly on the disk file, NOT on the inmemory db ;; 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) (db:with-lock-db dbfile (lambda (dbh dbfile) (db:get-iam-server-lock dbh dbfile)))) (define (db:with-lock-db dbfile proc) (let* ((dbh (db:open-run-db dbfile db:initialize-db)) (res (proc dbh dbfile))) ;; (sqlite3:finalize! dbh) res)) ;; called before db is open? ;; (define (db:get-iam-server-lock dbh dbfname port) (sqlite3:with-transaction dbh (lambda () (let* ((locker (db:get-locker dbh dbfname))) (if locker 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,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 port) ;; (condition-case ;; (begin (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)) ;;====================================================================== ;; SQLITE3 HELPERS ;;====================================================================== |
︙ | ︙ | |||
1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 | db (lambda () (sqlite3:execute db "CREATE TABLE IF NOT EXISTS locks (id INTEGER PRIMARY KEY, lockname TEXT, owner_pid INTEGER, owner_host 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 (id INTEGER PRIMARY KEY, host TEXT, | > | 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 | db (lambda () (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 (id INTEGER PRIMARY KEY, host TEXT, |
︙ | ︙ |
Modified rmtmod.scm from [db7ecb31bf] to [ae314078d9].
︙ | ︙ | |||
297 298 299 300 301 302 303 | ))) ;;====================================================================== ;; FOR DEBUGGING SET TO #t | | > | 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 | ))) ;;====================================================================== ;; FOR DEBUGGING SET TO #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)) (if (not *rmt:remote*)(set! *rmt:remote* (make-rmt:remote))) (let* ((apath *toppath*) |
︙ | ︙ | |||
409 410 411 412 413 414 415 416 417 418 419 420 421 422 | (define (rmt:kill-server run-id) (rmt:send-receive 'kill-server run-id (list run-id))) (define (rmt:start-server run-id) (rmt:send-receive 'start-server 0 (list run-id))) ;;====================================================================== ;; M I S C ;;====================================================================== (define (rmt:login run-id) (rmt:send-receive 'login run-id (list *toppath* megatest-version *my-signature*))) | > > > | 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 | (define (rmt:kill-server run-id) (rmt:send-receive 'kill-server run-id (list run-id))) (define (rmt:start-server run-id) (rmt:send-receive 'start-server 0 (list run-id))) (define (rmt:get-server-info apath dbname) (rmt:send-receive 'get-server-info 0 (list 0 apath dbname))) ;;====================================================================== ;; M I S C ;;====================================================================== (define (rmt:login run-id) (rmt:send-receive 'login run-id (list *toppath* megatest-version *my-signature*))) |
︙ | ︙ | |||
1485 1486 1487 1488 1489 1490 1491 | (inmem (dbr:dbdat-db dbdat)) ) ;; 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") | > | > > | > | 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 | (inmem (dbr:dbdat-db dbdat)) ) ;; 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") (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*) ".pkt"))) (debug:print-info 0 *default-log-port* "removing pkt "pkt-file) |
︙ | ︙ | |||
1674 1675 1676 1677 1678 1679 1680 | (servdat-trynum-set! *server-info* (+ (servdat-trynum *server-info*) 1))) (set! *server-info* (make-servdat host: ipaddrstr port: portnum))) (debug:print-info 0 *default-log-port* "rmt:try-start-server time=" (seconds->time-string (current-seconds)) " ipaddrsstr=" ipaddrstr " portnum=" portnum) | | | | | | | | | | 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 | (servdat-trynum-set! *server-info* (+ (servdat-trynum *server-info*) 1))) (set! *server-info* (make-servdat host: ipaddrstr port: portnum))) (debug:print-info 0 *default-log-port* "rmt:try-start-server time=" (seconds->time-string (current-seconds)) " ipaddrsstr=" ipaddrstr " portnum=" portnum) ;;(if (is-port-in-use portnum) ;; (begin ;; (portlogger:open-run-close portlogger:set-failed portnum) ;; (debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port") ;; ;; (thread-sleep! 0.1) ;; (rmt:try-start-server ipaddrstr ;; (portlogger:open-run-close ;; portlogger:find-port))) (begin (if (not *server-info*) (set! *server-info* (make-servdat host: ipaddrstr port: portnum))) (servdat-status-set! *server-info* 'starting) (servdat-port-set! *server-info* portnum) |
︙ | ︙ | |||
1712 1713 1714 1715 1716 1717 1718 | (debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port") ;; (thread-sleep! 0.1) (rmt:try-start-server ipaddrstr (portlogger:open-run-close portlogger:find-port))) (begin (print "ERROR: Tried and tried but could not start the server, stopping at port "portnum)))) (nng-listen rep (conc "tcp://*:" portnum)) | | | 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 | (debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port") ;; (thread-sleep! 0.1) (rmt:try-start-server ipaddrstr (portlogger:open-run-close portlogger:find-port))) (begin (print "ERROR: Tried and tried but could not start the server, stopping at port "portnum)))) (nng-listen rep (conc "tcp://*:" portnum)) rep)))) ;;) ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== ;;====================================================================== ;; C L I E N T S |
︙ | ︙ | |||
1814 1815 1816 1817 1818 1819 1820 | ;;====================================================================== ;; NEW SERVER METHOD ;;====================================================================== ;; only use for main.db - need to re-write some of this :( ;; | | | | > > > > > > > > > > > > | 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 | ;;====================================================================== ;; NEW SERVER METHOD ;;====================================================================== ;; only use for main.db - need to re-write some of this :( ;; (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) (let* ((pkt-dat `((host . ,host) (port . ,port) |
︙ | ︙ | |||
1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 | (if (null? tail) res ;; NOTE: sort by age so oldest is considered first (let* ((spkt (car tail))) (loop (cdr tail) (if (equal? dbpath (alist-ref 'dbpath spkt)) (cons spkt res) res)))))) ;; from viable servers get one that is alive and ready ;; (define (get-the-server apath serv-pkts) (let loop ((tail serv-pkts)) (if (null? tail) #f | > > > > > > > > > > > > > > > > > > > | 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 | (if (null? tail) res ;; NOTE: sort by age so oldest is considered first (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)) (if (null? tail) #f |
︙ | ︙ | |||
2003 2004 2005 2006 2007 2008 2009 | (get-host-name) (servdat-port sdat) server-key (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)) | > | | > > > > > > > | | | > | < < | 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 | (get-host-name) (servdat-port sdat) server-key (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)) (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 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-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) (sleep 4) (if (> (- (current-seconds) start-time) 120) ;; been waiting for two minutes |
︙ | ︙ | |||
2153 2154 2155 2156 2157 2158 2159 | ;; IFF I'm not main, call into main and register self (if (not is-main) (let ((res (rmt:register-server *rmt:remote* *toppath* iface port server-key dbname))) (if res ;; we are the server (servdat-status-set! *server-info* 'have-interface-and-db) | > > > > | > > > > | | | 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 | ;; IFF I'm not main, call into main and register self (if (not is-main) (let ((res (rmt:register-server *rmt:remote* *toppath* iface port server-key dbname))) (if res ;; we are the server (servdat-status-set! *server-info* 'have-interface-and-db) (let* ((serv-info (rmt:get-server-info *toppath* dbname))) (match serv-info ((host port servkey pid ipaddr apath dbpath) (if (not (server-ready? host port servkey)) (begin (debug:print-info 0 *default-log-port* "Server registered but not alive. Removing and trying again.") (rmt:deregister-server host port servkey pid ipaddr apath dbpath) (loop (+ count 1) bad-sync-count start-time)))) (else (debug:print 0 *default-log-port* "We are not the server for "dbname", exiting. Server info is: "serv-info) (exit))))))) (debug:print 0 *default-log-port* "SERVER: running, db "dbname" opened, megatest version: " (common:get-full-version)) ;; start the watchdog ;; is this really needed? |
︙ | ︙ |
Modified stml2.scm from [6f0ee137b2] to [c7394e5219].
︙ | ︙ | |||
16 17 18 19 20 21 22 23 24 25 | ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit stml2)) (declare (uses cookie)) (include "stml2/stml2.scm") | > > | 16 17 18 19 20 21 22 23 24 25 26 27 | ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit stml2)) (declare (uses cookie)) (declare (uses dbi)) (declare (uses autoload)) (include "stml2/stml2.scm") |
Modified stml2/formdat.scm from [f4b16c20f8] to [0f3102ec8c].
︙ | ︙ | |||
8 9 10 11 12 13 14 | ;; PURPOSE. ;; (declare (unit formdat)) (module formdat * | | < | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 | ;; PURPOSE. ;; (declare (unit formdat)) (module formdat * (import chicken scheme data-structures extras srfi-13 ports html-filter) (import regex) (import srfi-69) ) |
Modified stml2/html-filter.scm from [55ec64cff2] to [a2ae004691].
︙ | ︙ | |||
9 10 11 12 13 14 15 | ;; (declare (unit html-filter)) (module html-filter * (import chicken scheme data-structures extras srfi-13 ports ) | | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 | ;; (declare (unit html-filter)) (module html-filter * (import chicken scheme data-structures extras srfi-13 ports ) (import misc-stml) (import regex) ;; ) |
Modified stml2/misc-stml.scm from [30ba5d90bf] to [8660d67355].
︙ | ︙ | |||
14 15 16 17 18 19 20 | ;; (declare (unit misc-stml)) (module misc-stml * (import chicken scheme data-structures extras srfi-13 ports posix) | | | < | 14 15 16 17 18 19 20 21 22 23 | ;; (declare (unit misc-stml)) (module misc-stml * (import chicken scheme data-structures extras srfi-13 ports posix) (import regex (prefix dbi dbi:)) (import (prefix crypt c:)) ) |
Modified stml2/rollup-pages.scm from [b24bc2e231] to [37b97898ac].
|
| | | 1 2 3 4 5 6 7 8 | (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)") (if (hash-table-ref/default lookup (conc page "_ctrl") #f) (print "(include \"pages/" page "_ctrl.scm\")")) |
︙ | ︙ |
Modified stml2/session.scm from [300e7014a0] to [32b68ce58f].
︙ | ︙ | |||
9 10 11 12 13 14 15 | ;; (declare (unit session)) (module session * (import chicken scheme data-structures extras srfi-13 ports posix files srfi-1) | | < | | 9 10 11 12 13 14 15 16 17 18 19 | ;; (declare (unit session)) (module session * (import chicken scheme data-structures extras srfi-13 ports posix files srfi-1) (import (prefix dbi dbi:) srfi-69 regex) (import cookie stmlcommon) ;; (declare (uses cookie)) ) |
Modified stml2/setup.scm from [27fec5f813] to [6248624979].
1 2 3 4 5 6 7 8 9 10 11 12 13 | ;; Copyright 2007-2011, 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. (module setup * (import chicken scheme data-structures extras srfi-13 ports posix) | | | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | ;; Copyright 2007-2011, 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. (module setup * (import chicken scheme data-structures extras srfi-13 ports posix) (import session misc-stml) ;; (declare (unit setup))se ;; (declare (uses session)) (import srfi-69 regex) ) |
Modified stml2/spiffyserver.scm from [0953505b2d] to [36a130548d].
1 2 | ;; This doesn't work yet ;; | | | 1 2 3 4 5 6 7 8 9 10 | ;; This doesn't work yet ;; (import spiffy cgi-handler) (spiffy-debug-mode #t) (spiffy-file-ext-handlers `(("drcdb" . ,(cgi-handler* "/path/to/drcdb")))) (spiffy-root-path "/path/to/web") |
︙ | ︙ |
Modified stml2/sqlite3.scm from [935dbe7787] to [b0bb736749].
1 2 3 4 5 6 7 8 9 10 11 12 13 | ;; Copyright 2007-2011, 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. ;; ;; 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). | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | ;; Copyright 2007-2011, 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. ;; ;; 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). (import sqlite3) (define args (argv)) (define num-args (length args)) (define dbname #f) (define cmd #f) |
︙ | ︙ |
Modified stml2/stmlcommon.scm from [d0639f2742] to [ba756fc30d].
︙ | ︙ | |||
11 12 13 14 15 16 17 | ;; (declare (run-time-macros)) (module stmlcommon * (import chicken scheme data-structures extras srfi-13 ports posix) | | | 11 12 13 14 15 16 17 18 19 20 | ;; (declare (run-time-macros)) (module stmlcommon * (import chicken scheme data-structures extras srfi-13 ports posix) (import (prefix dbi dbi:) regex (prefix crypt c:) srfi-69) ) |
Modified stml2/stmlrun.scm from [a5be661fee] to [4939b15c7b].
︙ | ︙ | |||
9 10 11 12 13 14 15 | ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; (require-extension syntax-case) ;; (declare (run-time-macros)) ;; (include "stmlcommon.scm") | | | 9 10 11 12 13 14 15 16 17 18 19 | ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; (require-extension syntax-case) ;; (declare (run-time-macros)) ;; (include "stmlcommon.scm") (import stml) (stml:main #f) |
Modified stml2/test.scm from [62a996e095] to [6d65a60d4d].
|
| | < | 1 2 3 4 5 6 7 8 9 | (import test md5) (import (prefix sqlite3 sqlite3:)) (require-library dbi) ;; (declare (uses stml)) (include "requirements.scm") |
︙ | ︙ |
Modified tests/tests.scm from [2fa2f9d268] to [7467445dd0].
︙ | ︙ | |||
13 14 15 16 17 18 19 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') | | > > > > > > > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') (import srfi-18 test chicken.string chicken.process-context chicken.file chicken.pretty-print commonmod ) (define test-work-dir (current-directory)) ;; given list of lists ;; ( ( msg expected param1 param2 ...) ;; ( ... ) ) ;; apply test to all |
︙ | ︙ |
Modified testsmod.scm from [13d6172d0b] to [1d551a945a].
︙ | ︙ | |||
24 25 26 27 28 29 30 31 32 33 34 35 36 37 | (declare (uses commonmod)) (declare (uses configfmod)) (declare (uses itemsmod)) (declare (uses rmtmod)) (declare (uses stml2)) (declare (uses dbmod)) (declare (uses tasksmod)) (module testsmod * (import scheme chicken.base | > | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | (declare (uses commonmod)) (declare (uses configfmod)) (declare (uses itemsmod)) (declare (uses rmtmod)) (declare (uses stml2)) (declare (uses dbmod)) (declare (uses tasksmod)) (declare (uses dbi)) (module testsmod * (import scheme chicken.base |
︙ | ︙ |