Changes In Branch v1.66-captain-ulex Excluding Merge-Ins
This is equivalent to a diff from 2b412d7468 to 6c77d0ada6
2020-08-21
| ||
16:52 | Merged in changes from v1.65 to ease syncing Leaf check-in: 6c77d0ada6 user: mrwellan tags: v1.66-captain-ulex | |
2020-08-03
| ||
10:01 | Sync check-in: 686c5895a7 user: mrwellan tags: v1.66-captain-ulex | |
2020-07-28
| ||
22:41 | Pulled in v1.66 check-in: 2b506bbc72 user: matt tags: v1.66-captain-ulex | |
22:23 | Merged v1.65 Leaf check-in: 2b412d7468 user: matt tags: v1.66 | |
15:51 | Do not exit on issues creating link tree. Continue on. If the links were not properly removed let's fix the removal process rather than bandaid here. check-in: e49d32d625 user: mrwellan tags: v1.65, v1.6557 | |
2020-07-26
| ||
14:11 | Merged in latest from v1.65 check-in: 7e9e931afb user: matt tags: v1.66 | |
Modified Makefile from [0948aa4fa3] to [60d541cecc].
︙ | ︙ | |||
19 20 21 22 23 24 25 | # rm <files>.o ; make install CSCOPTS='-profile' ; ... ; chicken-profile | less SHELL=/bin/bash PREFIX=$(PWD) CSCOPTS= INSTALL=install SRCFILES = common.scm items.scm launch.scm ods.scm runconfig.scm \ server.scm configf.scm db.scm keys.scm margs.scm \ | | | | | < | | > > | > | | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 | # rm <files>.o ; make install CSCOPTS='-profile' ; ... ; chicken-profile | less SHELL=/bin/bash PREFIX=$(PWD) CSCOPTS= INSTALL=install SRCFILES = common.scm items.scm launch.scm ods.scm runconfig.scm \ server.scm configf.scm db.scm keys.scm margs.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ http-transport.scm filedb.scm tdb.scm client.scm mt.scm \ ezsteps.scm lock-queue.scm sdb.scm rmt.scm api.scm \ subrun.scm portlogger.scm archive.scm env.scm \ diff-report.scm cgisetup/models/pgdb.scm # module source files # ftail.scm rmtmod.scm commonmod.scm removed MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm \ mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm \ rmtmod.scm apimod.scm GUISRCF = dashboard-context-menu.scm dashboard-tests.scm \ dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm \ vg.scm OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o)) # compiled import files MOIMPFILES = $(MSRCFILES:%.scm=%.import.o) %.import.o : %.import.scm csc $(CSCOPTS) -unit $*.import -c $*.import.scm -o $*.import.o # I'm not sure the cp is a good idea, changed a lot of things and it may not have been necessary... mofiles/%.o %.import.scm : %.scm megatest-fossil-hash.scm @[ -e mofiles ] || mkdir -p mofiles csc $(CSCOPTS) -I mofiles -I $* -J -c $< -o $*.o cp $*.o mofiles/$*.o @touch $*.import.scm # ensure it is touched after the .o is made ADTLSCR=mt_laststep mt_runstep mt_ezstep HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR)) DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR)) MTESTHASH=$(shell fossil info|grep checkout:| awk '{print $$2}') |
︙ | ︙ | |||
71 72 73 74 75 76 77 | mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) $(MOIMPFILES) csc $(CSCOPTS) $(OFILES) $(MOFILES) $(MOIMPFILES) megatest.o -o mtest showmtesthash: @echo $(MTESTHASH) | | < < < | < < < | > > | > > | | | > > | | | | > > > > < < < < < < < < < | 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 | mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) $(MOIMPFILES) csc $(CSCOPTS) $(OFILES) $(MOFILES) $(MOIMPFILES) megatest.o -o mtest showmtesthash: @echo $(MTESTHASH) dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) $(MOIMPFILES) megatest-version.scm megatest-fossil-hash.scm csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) $(MOIMPFILES) -o dboard mtut: $(OFILES) $(MOFILES) megatest-fossil-hash.scm mtut.scm megatest-version.scm csc $(CSCOPTS) $(OFILES) $(MOFILES) mtut.scm -o mtut include makefile.inc TCMTOBJS = \ api.o \ archive.o \ cgisetup/models/pgdb.o \ client.o \ common.o \ configf.o \ db.o \ env.o \ http-transport.o \ items.o \ keys.o \ launch.o \ lock-queue.o \ margs.o \ mt.o \ ods.o \ portlogger.o \ process.o \ rmt.o \ runconfig.o \ runs.o \ server.o \ tasks.o \ tdb.o \ tests.o \ subrun.o \ ezsteps.o # mofiles/commonmod.o \ tcmt : $(TCMTOBJS) tcmt.scm megatest-version.scm csc $(CSCOPTS) $(TCMTOBJS) $(MOFILES) $(MOIMPFILES) tcmt.scm -o tcmt # install documentation to $(PREFIX)/docs # DOES NOT REBUILD DOCS # $(PREFIX)/share/docs/megatest_manual.html : docs/manual/megatest_manual.html mkdir -p $(PREFIX)/share/docs $(INSTALL) docs/manual/megatest_manual.html $(PREFIX)/share/docs/megatest_manual.html for png in $(PNGFILES);do $(INSTALL) docs/manual/$$png $(PREFIX)/share/docs/$$png;done # add a fake dependency so this doens't copy everytime $(PREFIX)/share/js/jquery-3.1.0.slim.min.js : # .fslckout mkdir -p $(PREFIX)/share/js fossil wiki export java-script-lib > $(PREFIX)/share/js/jquery-3.1.0.slim.min.js $(PREFIX)/share/db/mt-pg.sql : mt-pg.sql mkdir -p $(PREFIX)/share/db $(INSTALL) mt-pg.sql $(PREFIX)/share/db/mt-pg.sql # Special dependencies for the includes $(MOFILE) $(MOIMPFILES) : megatest-fossil-hash.scm common.o : mofiles/commonmod.o megatest-fossil-hash.scm commonmod.o dashboard.o megatest.o tcmt.o apimod.o : megatest-fossil-hash.scm tests.o db.o launch.o runs.o dashboard-tests.o \ dashboard-context-menu.o dashboard-guimonitor.o dashboard-main.o \ monitor.o dashboard.o archive.o megatest.o : db_records.scm megatest-fossil-hash.scm tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o : run_records.scm db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm tests.o tasks.o dashboard-tasks.o : task_records.scm runs.o : test_records.scm megatest.o : megatest-fossil-hash.scm megatest-version.scm rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm common_records.scm : altdb.scm mofiles/stml2.o : mofiles/cookie.o configf.o : mofiles/commonmod.o vg.o dashboard.o : vg_records.scm dcommon.o : run_records.scm mofiles/stml2.o : mofiles/cookie.o # special include based modules mofiles/pkts.o : pkts/pkts.scm mofiles/stml2.o : cookie.o # mofiles/mtargs.o : mtargs/mtargs.scm # mofiles/mtconfigf.o : mtconfigf/mtconfigf.scm mofiles/ulex.o : ulex/ulex.scm mofiles/mutils.o : mutils/mutils.scm mofiles/cookie.o : stml2/cookie.scm mofiles/stml2.o : stml2/stml2.scm # for the modularized stuff rmt.o : mofiles/ducttape-lib.o mofiles/pkts.o mofiles/stml2.o mofiles/mutils.o mofiles/mtargs.o mofiles/rmtmod.o : mofiles/apimod.o mofiles/ulex.o megatest-fossil-hash.scm : .fslckout @echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new @if [[ ! -e megatest-fossil-hash.scm ]] || ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi $(OFILES) $(GOFILES) : common_records.scm # This having the full list of MOFILES cause everything to be rebuilt every time. # # %.o : %.scm $(MOFILES) # csc $(CSCOPTS) -c $< $(MOFILES) # %.o : %.scm megatest-fossil-hash.scm csc $(CSCOPTS) -c $< # specific rules for .o files that genuninely depend on mofiles/something # megatest.o : megatest.scm stml2.o mutils.o commonmod.o csc $(CSCOPTS) -c megatest.scm stml2.o mutils.o commonmod.o dashboard.o : dashboard.scm stml2.o mutils.o commonmod.o dbmod.o csc $(CSCOPTS) -c megatest.scm stml2.o mutils.o commonmod.o dbmod.o common.o : megatest.scm mofiles/commonmod.o common.scm csc $(CSCOPTS) -c common.scm mofiles/commonmod.o configf.o : configf.scm mofiles/commonmod.o csc $(CSCOPTS) -c configf.scm mofiles/commonmod.o $(PREFIX)/bin/.$(ARCHSTR)/bin/mtest : mtest $(PREFIX)/bin/megatest : $(PREFIX)/bin/.$(ARCHSTR)/bin/mtest utils/mk_wrapper $(PREFIX)/bin/.$(ARCHSTR)/bin/mtest : mtest @echo Installing to PREFIX=$(PREFIX) $(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/bin/mtest $(PREFIX)/bin/megatest : $(PREFIX)/bin/.$(ARCHSTR)/bin/mtest utils/mk_wrapper utils/mk_wrapper $(PREFIX) mtest $(PREFIX)/bin/megatest chmod a+x $(PREFIX)/bin/megatest $(PREFIX)/bin/.$(ARCHSTR)/bin/mtut : mtut $(INSTALL) mtut $(PREFIX)/bin/.$(ARCHSTR)/bin/mtut install-mtut : mtut $(INSTALL) mtut $(PREFIX)/bin/mtut $(PREFIX)/bin/mtutil : $(PREFIX)/bin/.$(ARCHSTR)/bin/mtut utils/mk_wrapper |
︙ | ︙ | |||
347 348 349 350 351 352 353 | $(MTQA_FOSSIL) : fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL) clean : rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) \ $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil mtut \ | | | | | 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 | $(MTQA_FOSSIL) : fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL) clean : rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) \ $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil mtut \ tcmt readline-fix.scm serialize-env dboard *.o \ megatest-fossil-hash.* altdb.scm mofiles/*.o \ mofiles/*.o vg.o cookie.o dashboard-main.o \ ducttape-lib.o ftail.o mutils.o pkts.o rmtmod.o stml2.o \ tcmt.o rm -rf share #====================================================================== # Deploy section (not complete yet) #====================================================================== |
︙ | ︙ | |||
396 397 398 399 400 401 402 | sd : datashare-testing/sd mkdir -p /tmp/$(USER)/datashare/disk1 /tmp/$(USER)/basepath xterm : sd (export BASEPATH=/tmp/$(USER)/basepath ; export PATH="$(PWD)/datashare-testing:$(PATH)" ; xterm &) | | | | | | | | 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 | sd : datashare-testing/sd mkdir -p /tmp/$(USER)/datashare/disk1 /tmp/$(USER)/basepath xterm : sd (export BASEPATH=/tmp/$(USER)/basepath ; export PATH="$(PWD)/datashare-testing:$(PATH)" ; xterm &) datashare-testing/spublish : spublish.scm $(OFILES) megatest-version.scm csc $(CSCOPTS) spublish.scm margs.o process.o common.o -o datashare-testing/spublish datashare-testing/sretrieve : sretrieve.scm $(OFILES) megatest-version.scm csc $(CSCOPTS) sretrieve.scm margs.o process.o common.o -o datashare-testing/sretrieve datashare-testing/sauthorize : sauthorize.scm $(OFILES) megatest-version.scm csc $(CSCOPTS) sauthorize.scm margs.o process.o common.o -o datashare-testing/sauthorize sauth-init: mkdir -p datashare-testing rm datashare-testing/sauthorize rm datashare-testing/sretrieve rm datashare-testing/spublish |
︙ | ︙ | |||
443 444 445 446 447 448 449 450 451 452 453 454 455 456 | targets: @grep : Makefile | perl -ne '/^([A-Za-z0-9_-]+):/ && print "$$1\n"' unit : cd tests;make unit #====================================================================== # Attic #====================================================================== # portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o # csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o | > > > > > > > > > > > > > > > > > > > > | 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 | targets: @grep : Makefile | perl -ne '/^([A-Za-z0-9_-]+):/ && print "$$1\n"' unit : cd tests;make unit ALLSCMFILES=$(shell ls *scm|grep -v import) ALLREINDENT=$(addprefix reindent/,$(ALLSCMFILES)) indentreport : reindentall @for x in $(ALLSCMFILES);do if ! diff -q $$x reindent/$$x > /dev/null;then echo "FAIL $$x";fi;done reindentall : $(ALLREINDENT) echo "ENSURE YOU HAVE THE LINES FROM emacs.config IN YOUR ~/.emacs FILE!" reindent/README : mkdir -p reindent echo "Indent modified files are put here." > reindent/README reindent/%.scm : %.scm reindent/README cp $< reindent cd reindent;emacs -batch $< --eval '(load "$(PWD)/reindent.el")' -f save-buffer # cd reindent;emacs -batch $< --eval '(indent-region (point-min) (point-max) nil)' -f save-buffer #====================================================================== # Attic #====================================================================== # portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o # csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o |
︙ | ︙ |
Modified TODO from [ff0b580779] to [da5eae4898].
︙ | ︙ | |||
11 12 13 14 15 16 17 | # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with Megatest. If not, see <http://www.gnu.org/licenses/>. | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with Megatest. If not, see <http://www.gnu.org/licenses/>. TODO ==== WW15 . fill newview matrix with data, filter pipeline gui elements . improve [script], especially indent handling |
︙ | ︙ | |||
104 105 106 107 108 109 110 111 112 | Migration to inmem db plus per run db ------------------------------------- . Re-work the dbstruct data structure? .. Move main.db to global? .. [ run-id.db inmemdb last-mod last-read last-sync inuse ] . Open main.db directly in calls to -runtests etc. No need to talk remote? | > > | 48 49 50 51 52 53 54 55 56 57 58 | Migration to inmem db plus per run db ------------------------------------- . Re-work the dbstruct data structure? .. Move main.db to global? .. [ run-id.db inmemdb last-mod last-read last-sync inuse ] . Re-work all queries to use run-id to dereference server . Open main.db directly in calls to -runtests etc. No need to talk remote? . remove common:faux-lock |
Modified adjutant.scm from [419fdc41ba] to [7560fecb1c].
︙ | ︙ | |||
16 17 18 19 20 21 22 | ;; 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 adjutant)) | | | < | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | ;; 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 adjutant)) (module adjutant * (import scheme chicken data-structures extras files) (import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 md5 message-digest regex srfi-1) (define (adjutant-run) (print "Running the adjutant!")) |
︙ | ︙ |
Modified api.scm from [8a3eb8aa72] to [2fafc2d0fe].
︙ | ︙ | |||
79 80 81 82 83 84 85 | read-test-data* login tasks-get-last testmeta-get-record have-incompletes? ;; synchash-get get-changed-record-ids | | | > > > | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 | read-test-data* login tasks-get-last testmeta-get-record have-incompletes? ;; synchash-get get-changed-record-ids get-run-record-ids get-not-completed-cnt)) (define api:write-queries '( get-keys-write ;; dummy "write" query to force server start ;; SERVERS start-server kill-server ;; TESTS test-set-state-status-by-id delete-test-records delete-old-deleted-test-records test-set-state-status test-set-top-process-pid set-state-status-and-roll-up-items update-pass-fail-counts top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst") ;; RUNS register-run set-tests-state-status delete-run lock/unlock-run update-run-event_time mark-incomplete set-state-status-and-roll-up-run ;; STEPS teststep-set-status! delete-steps-for-test ;; TEST DATA test-data-rollup csv->test-data ;; MISC sync-inmem->db drop-all-triggers create-all-triggers update-tesdata-on-repilcate-db ;; TESTMETA testmeta-add-record testmeta-update-field ;; TASKS tasks-add |
︙ | ︙ | |||
211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 | ((register-run) (apply db:register-run dbstruct params)) ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params)) ((delete-run) (apply db:delete-run dbstruct params)) ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params)) ((update-run-event_time) (apply db:update-run-event_time dbstruct params)) ((update-run-stats) (apply db:update-run-stats dbstruct params)) ((set-var) (apply db:set-var dbstruct params)) ((del-var) (apply db:del-var dbstruct params)) ;; STEPS ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) ((delete-steps-for-test!) (apply db:delete-steps-for-test! dbstruct params)) ;; TEST DATA ((test-data-rollup) (apply db:test-data-rollup dbstruct params)) ((csv->test-data) (apply db:csv->test-data dbstruct params)) ;; MISC ((sync-inmem->db) (let ((run-id (car params))) (db:sync-touched dbstruct run-id force-sync: #t))) ((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params)) ;; TESTMETA ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params)) ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params)) ((get-tests-tags) (db:get-tests-tags dbstruct)) ;; TASKS ((tasks-add) (apply tasks:add dbstruct params)) ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params)) ((tasks-get-last) (apply tasks:get-last dbstruct params)) ;; NO SYNC DB ((no-sync-set) (apply db:no-sync-set *no-sync-db* params)) ((no-sync-get/default) (apply db:no-sync-get/default *no-sync-db* params)) ((no-sync-del!) (apply db:no-sync-del! *no-sync-db* params)) ((no-sync-get-lock) (apply db:no-sync-get-lock *no-sync-db* params)) | > > > > > | | 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 | ((register-run) (apply db:register-run dbstruct params)) ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params)) ((delete-run) (apply db:delete-run dbstruct params)) ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params)) ((update-run-event_time) (apply db:update-run-event_time dbstruct params)) ((update-run-stats) (apply db:update-run-stats dbstruct params)) ((set-var) (apply db:set-var dbstruct params)) ((inc-var) (apply db:inc-var dbstruct params)) ((dec-var) (apply db:dec-var dbstruct params)) ((del-var) (apply db:del-var dbstruct params)) ((add-var) (apply db:add-var dbstruct params)) ;; STEPS ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) ((delete-steps-for-test!) (apply db:delete-steps-for-test! dbstruct params)) ;; TEST DATA ((test-data-rollup) (apply db:test-data-rollup dbstruct params)) ((csv->test-data) (apply db:csv->test-data dbstruct params)) ;; MISC ((sync-inmem->db) (let ((run-id (car params))) (db:sync-touched dbstruct run-id force-sync: #t))) ((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params)) ((create-all-triggers) (db:create-all-triggers dbstruct)) ((drop-all-triggers) (db:drop-all-triggers dbstruct)) ;; TESTMETA ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params)) ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params)) ((get-tests-tags) (db:get-tests-tags dbstruct)) ;; TASKS ((tasks-add) (apply tasks:add dbstruct params)) ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params)) ((tasks-get-last) (apply tasks:get-last dbstruct params)) ;; NO SYNC DB ((no-sync-set) (apply db:no-sync-set *no-sync-db* params)) ((no-sync-get/default) (apply db:no-sync-get/default *no-sync-db* params)) ((no-sync-del!) (apply db:no-sync-del! *no-sync-db* params)) ((no-sync-get-lock) (apply db:no-sync-get-lock *no-sync-db* params)) ;; ARCHIVES ;; ((archive-get-allocations) ((archive-register-disk) (apply db:archive-register-disk dbstruct params)) ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params)) ;; ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey)) ;;====================================================================== |
︙ | ︙ | |||
290 291 292 293 294 295 296 297 298 299 300 301 302 303 | ;; RUNS ((get-run-info) (apply db:get-run-info dbstruct params)) ((get-run-status) (apply db:get-run-status dbstruct params)) ((get-run-state) (apply db:get-run-state dbstruct params)) ((set-run-status) (apply db:set-run-status dbstruct params)) ((set-run-state-status) (apply db:set-run-state-status dbstruct params)) ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params)) ((get-tests-for-run-state-status) (apply db:get-tests-for-run-state-status dbstruct params)) ((get-test-id) (apply db:get-test-id dbstruct params)) ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params)) ;; ((get-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params)) ((get-runs) (apply db:get-runs dbstruct params)) ((simple-get-runs) (apply db:simple-get-runs dbstruct params)) | > | 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 | ;; RUNS ((get-run-info) (apply db:get-run-info dbstruct params)) ((get-run-status) (apply db:get-run-status dbstruct params)) ((get-run-state) (apply db:get-run-state dbstruct params)) ((set-run-status) (apply db:set-run-status dbstruct params)) ((set-run-state-status) (apply db:set-run-state-status dbstruct params)) ((update-tesdata-on-repilcate-db) (apply db:update-tesdata-on-repilcate-db dbstruct params)) ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params)) ((get-tests-for-run-state-status) (apply db:get-tests-for-run-state-status dbstruct params)) ((get-test-id) (apply db:get-test-id dbstruct params)) ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params)) ;; ((get-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params)) ((get-runs) (apply db:get-runs dbstruct params)) ((simple-get-runs) (apply db:simple-get-runs dbstruct params)) |
︙ | ︙ |
Added apimod.scm version [0c866deee4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 29 30 31 32 33 34 35 36 37 | ;;====================================================================== ;; Copyright 2017, Matthew Welland. ;; ;; This file is part of Megatest. ;; ;; Megatest is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; Megatest is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit apimod)) (declare (uses commonmod)) (declare (uses ulex)) (module apimod * (import scheme chicken data-structures extras) (import (prefix sqlite3 sqlite3:) posix typed-records srfi-18) (import commonmod) (import (prefix ulex ulex:)) (define (api:execute-requests params) #f) ) |
Modified archive.scm from [212cc6c596] to [aac3410192].
︙ | ︙ | |||
134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 | ;; (define (archive:run-bup archive-command run-id run-name tests rp-mutex bup-mutex) ;; move the getting of archive space down into the below block so that a single run can ;; allocate as needed should a disk fill up ;; (let* ((blockid-cache (make-hash-table)) (tsname (common:get-testsuite-name)) (min-space (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000"))) (arch-groups (make-hash-table)) ;; archive groups, each corrosponds to a bup area (disk-groups (make-hash-table)) ;; (test-groups (make-hash-table)) ;; these two (disk and test groups) could be combined nicely (test-dirs (make-hash-table)) (bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) (compress (or (configf:lookup *configdat* "archive" "compress") "9")) (linktree (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))) (archiver (let ((s (configf:lookup *configdat* "archive" "archiver"))) (if s (string->symbol s) 'bup))) (archiver-cmd (case archiver ((tar) "tar cfj ARCHIVE_NAME.tar.bz2 ") ((7z) " 7z u -t7z -m0=lzma -mx=9 -mfb=64 -md=32m -ms=on ARCHIVE_NAME.7z ") (else #f))) (print-prefix "Running: ") ;; change to #f to turn off printing (preclean-spec (configf:get-section *configdat* "archive-preclean"))) ;; (tests:match patt testname itempath) ;; from the test info bin the path to the test by stem ;; (for-each (lambda (test-dat) (let* ((item-path (db:test-get-item-path test-dat)) (test-name (db:test-get-testname test-dat)) (test-id (db:test-get-id test-dat)) (run-id (db:test-get-run_id test-dat)) | > > > > < | | < < | 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 | ;; (define (archive:run-bup archive-command run-id run-name tests rp-mutex bup-mutex) ;; move the getting of archive space down into the below block so that a single run can ;; allocate as needed should a disk fill up ;; (let* ((blockid-cache (make-hash-table)) (tsname (common:get-testsuite-name)) (target (string-intersperse (map cadr (rmt:get-key-val-pairs run-id)) "/")) (min-space (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000"))) (arch-groups (make-hash-table)) ;; archive groups, each corrosponds to a bup area (disk-groups (make-hash-table)) ;; (test-groups (make-hash-table)) ;; these two (disk and test groups) could be combined nicely (test-dirs (make-hash-table)) (bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) (compress (or (configf:lookup *configdat* "archive" "compress") "9")) (linktree (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))) (archiver (let ((s (configf:lookup *configdat* "archive" "archiver"))) (if s (string->symbol s) 'bup))) (archiver-cmd (case archiver ((tar) "tar cfj ARCHIVE_NAME.tar.bz2 ") ((7z) " 7z u -t7z -m0=lzma -mx=9 -mfb=64 -md=32m -ms=on ARCHIVE_NAME.7z ") (else #f))) (src-archive-linktree (rmt:get-var "src-archive-linktree")) (print-prefix "Running: ") ;; change to #f to turn off printing (preclean-spec (configf:get-section *configdat* "archive-preclean"))) (if (or (not src-archive-linktree) (not (equal? src-archive-linktree linktree))) (rmt:set-var "src-archive-linktree" linktree)) ;; (tests:match patt testname itempath) ;; from the test info bin the path to the test by stem ;; (for-each (lambda (test-dat) (let* ((item-path (db:test-get-item-path test-dat)) (test-name (db:test-get-testname test-dat)) (test-id (db:test-get-id test-dat)) (run-id (db:test-get-run_id test-dat)) (toplevel/children (and (db:test-get-is-toplevel test-dat) (> (rmt:test-toplevel-num-items run-id test-name) 0))) (test-partial-path (conc target "/" run-name "/" (db:test-make-full-name test-name item-path))) ;; note the trailing slash to get the dir inspite of it being a link (test-path (conc linktree "/" test-partial-path)) (mutex-lock! rp-mutex) (test-physical-path (if (common:file-exists? test-path) (common:real-path test-path) #f)) (mutex-unlock! rp-mutex) (partial-path-index (if test-physical-path (substring-index test-partial-path test-physical-path) #f)) (test-base (if (and partial-path-index test-physical-path ) (substring test-physical-path 0 partial-path-index) #f)) ;; we need our archive dir checked for every test to enable folks who want to store other ways. (archive-info (archive:allocate-new-archive-block blockid-cache *toppath* tsname min-space target run-name test-name)) (archive-dir (if archive-info (cdr archive-info) #f)) (archive-id (if archive-info (car archive-info) -1))) (if (not archive-dir) ;; no archive disk found, this is fatal (begin (debug:print 0 *default-log-port* "FATAL: No archive disks found. Please add disks with at least " min-space " MB space to the [archive-disks] section of megatest.config") (debug:print 0 *default-log-port* " use [archive] minspace to specify minimum available space") (debug:print 0 *default-log-port* " disks: " |
︙ | ︙ | |||
310 311 312 313 314 315 316 | (hash-table-ref test-groups test-base)))) ;; (mutex-unlock! bup-mutex) (for-each (lambda (test-dat) (let ((test-id (db:test-get-id test-dat)) (run-id (db:test-get-run_id test-dat))) (rmt:test-set-archive-block-id run-id test-id archive-id) | | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 | (hash-table-ref test-groups test-base)))) ;; (mutex-unlock! bup-mutex) (for-each (lambda (test-dat) (let ((test-id (db:test-get-id test-dat)) (run-id (db:test-get-run_id test-dat))) (rmt:test-set-archive-block-id run-id test-id archive-id) (if (member (symbol->string archive-command) '("save-remove")) (begin (debug:print-info 0 *default-log-port* "remove testdat") (runs:remove-test-directory test-dat 'archive-remove))))) (hash-table-ref test-groups test-base))))) (hash-table-keys disk-groups)) #t)) (define (archive:megatest-db target-patt run-patt) (let* ((blockid-cache (make-hash-table)) (tsname (common:get-testsuite-name)) (min-space (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000"))) (bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) (compress (or (configf:lookup *configdat* "archive" "compress") "9")) (archiver (let ((s (configf:lookup *configdat* "archive" "archiver"))) (if s (string->symbol s) 'bup))) (rsync-exe (or (configf:lookup *configdat* "archive" "rsync") "rsync")) (print-prefix "Running: ") (archive-info (archive:allocate-new-archive-block blockid-cache *toppath* tsname min-space target-patt run-patt "megatest-db")) (archive-dir (if archive-info (cdr archive-info) #f)) (archive-id (if archive-info (car archive-info) -1)) (home-host (common:get-homehost)) (archive-time (seconds->std-time-str (current-seconds))) (archive-staging-db (conc *toppath* "/logs/archive_" archive-time)) (tmp-db-path (conc (common:get-db-tmp-area) "/megatest.db")) (dbfile (conc archive-staging-db "/megatest.db"))) (create-directory archive-staging-db #t) (let-values (((pid-val exit-status exit-code) (run-n-wait rsync-exe params: (list "-v" (conc (car home-host) ":"tmp-db-path) archive-staging-db) print-cmd: print-prefix))) (if (eq? exit-code 0) (case archiver ((bup) ;; Archive using bup (let* ((bup-init-params (list "-d" archive-dir "init")) (bup-index-params (list "-d" archive-dir "index" archive-staging-db)) (bup-save-params (list "-d" archive-dir "save" ;; (conc "--strip-path=" linktree) (conc "-" compress) ;; or (conc "--compress=" compress) "-n" (conc tsname "-megatest-db" ) (conc "--strip-path=" archive-staging-db ) ;; if we push to the directory do we need this? dbfile))) (if (not (common:file-exists? (conc archive-dir "/HEAD"))) (begin ;; replace this with jobrunner stuff enventually (debug:print-info 0 *default-log-port* "Init bup in " archive-dir) (run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix))) (debug:print-info 0 *default-log-port* "Indexing data to be archived") (run-n-wait bup-exe params: bup-index-params print-cmd: print-prefix) (debug:print-info 0 *default-log-port* "Archiving data with bup") (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix))) (else (debug:print-info 0 *default-log-port* "No support for databse archiving with " archiver))) (debug:print-error 0 *default-log-port* "There was an error rsyncing tmp database"))))) (define (archive:restore-db archive-path ts) (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) (archive-internal-path (conc (common:get-testsuite-name) "-megatest-db/" ts "/megatest.db" )) (bup-restore-params (list "-d" archive-path "restore" "-C" *toppath* archive-internal-path))) (debug:print-info 0 *default-log-port* "Restoring archived data to " *toppath* " from archive in " archive-path " ... " archive-internal-path) (run-n-wait bup-exe params: bup-restore-params print-cmd: #f)) (db:multi-db-sync (db:setup #f) 'killservers ;'dejunk ;'adj-testids 'old2new ) (debug:print-info 1 *default-log-port* "dropping trigerrs to update linktree") (rmt:drop-all-triggers) (let* ((linktree (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))) (src-archive-linktree (rmt:get-var "src-archive-linktree"))) (if (not (equal? src-archive-linktree linktree)) (rmt:update-tesdata-on-repilcate-db src-archive-linktree linktree)) (debug:print-info 1 *default-log-port* "creating triggers after updating linktree") (rmt:create-all-triggers) )) (define (archive:ls->list bup-exe archive-dir internal-path) (let ((cmd (conc bup-exe " -d " archive-dir " ls -l " internal-path "| awk '{print $6}' | sort")) (res '())) (handle-exceptions exn #f ;; anything goes wrong - assume the process in NOT running. (with-input-from-pipe cmd (lambda () (let* ((inl (read-lines))) (reverse inl))))))) (define (time-string->seconds tstr ds-flag) (let* ((atime (string->time tstr "%Y-%m-%d-%H%M%S"))) (vector-set! atime 8 ds-flag) (local-time->seconds atime))) (define (seconds->std-time-str sec) (time->string (seconds->local-time sec) "%Y-%m-%d-%H%M%S")) (define (archive:get-timestamp-dir bup-exe archive-dir testsuite-name run-id test-partial-path test-last-update) (print (seconds->std-time-str test-last-update)) (let* ((internal-path (conc testsuite-name "-" run-id)) (ts-list (archive:ls->list bup-exe archive-dir internal-path)) (ds-flag (vector-ref (seconds->local-time) 8))) (let loop ((hed (car ts-list)) (tail (cdr ts-list))) (if (and (null? tail) (equal? hed "latest")) #f (if (and (not (null? tail)) (equal? hed "latest")) (loop (car tail) (cdr tail)) (let* ((archive-seconds (time-string->seconds hed ds-flag))) (if (< (abs (- archive-seconds test-last-update)) 120) (let* ((test-list (archive:ls->list bup-exe archive-dir (conc internal-path "/" hed "/" test-partial-path)))) (if (> (length test-list) 0) hed (if (not (null? tail)) (loop (car tail) (cdr tail)) #f))) (if (null? tail) #f (loop (car tail) (cdr tail)))))))))) (define (archive:bup-restore archive-command run-id run-name tests rp-mutex bup-mutex) ;; move the getting of archive space down into the below block so that a single run can ;; allocate as needed should a disk fill up ;; (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) (linktree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree"))) ;; from the test info bin the path to the test by stem |
︙ | ︙ | |||
349 350 351 352 353 354 355 356 357 358 359 | (prev-test-physical-path (if (common:file-exists? test-path) ;; (read-symbolic-link test-path #t) (common:real-path test-path) #f)) (mutex-unlock! rp-mutex) (new-test-physical-path (conc best-disk "/" test-partial-path)) (archive-block-id (db:test-get-archived test-dat)) (archive-block-info (rmt:test-get-archive-block-info archive-block-id)) (archive-path (if (vector? archive-block-info) (vector-ref archive-block-info 2) ;; look in db.scm for test-get-archive-block-info for the vector record info #f)) ;; no archive found? | > > | | > > < < < < > | | 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 | (prev-test-physical-path (if (common:file-exists? test-path) ;; (read-symbolic-link test-path #t) (common:real-path test-path) #f)) (mutex-unlock! rp-mutex) (new-test-physical-path (conc best-disk "/" test-partial-path)) (archive-block-id (db:test-get-archived test-dat)) (test-last-update (db:test-get-last_update test-dat)) (archive-block-info (rmt:test-get-archive-block-info archive-block-id)) (archive-path (if (vector? archive-block-info) (vector-ref archive-block-info 2) ;; look in db.scm for test-get-archive-block-info for the vector record info #f)) ;; no archive found? (archive-timestamp-dir (if archive-path (archive:get-timestamp-dir bup-exe archive-path (common:get-testsuite-name) run-id test-partial-path test-last-update) #f)) (archive-internal-path (conc (common:get-testsuite-name) "-" run-id "/" archive-timestamp-dir "/" test-partial-path)) (include-paths (args:get-arg "-include")) (exclude-pattern (args:get-arg "-exclude-rx")) (exclude-file (args:get-arg "-exclude-rx-from"))) (if (not archive-timestamp-dir) (debug:print-error 0 *default-log-port* "Archive not found for testsuite" (common:get-testsuite-name) " run/test/itempath" test-partial-path) (begin ;; some sanity checks, move an existing path out of the way - iif it is not a toplevel with children (if (and (not toplevel/children) ;; special handling needed for toplevel with children prev-test-physical-path (common:file-exists? prev-test-physical-path)) ;; what to do? abort or clean up or link it in? (let* ((base (pathname-directory prev-test-physical-path)) (dirn (pathname-file prev-test-physical-path)) (newn (conc base "/." dirn))) (debug:print-error 0 *default-log-port* "the old directory " prev-test-physical-path ", still exists! Moving it to " newn) (rename-file prev-test-physical-path newn))) (if (and archive-path ;; no point in proceeding if there is no actual archive (not toplevel/children)) (begin ;; CREATE WORK AREA ;; test-src-path == #f ==> don't copy in data from tests directory ;; itemdat == string ==> use directly (create-work-area run-id run-name keyvals test-id #f best-disk test-name item-path) ;; #!key (remtries 2)) ;; 1. Get the block id from the test info ;; 2. Get the block data given the block id ;; 3. Construct the paths etc. for the following command: ;; bup -d /tmp/matt/adisk1/2015_q1/fullrun_e1a40/ restore -C /tmp/seeme fullrun-30/latest/ubuntu/nfs/none/w02.1.20.54_b/ ;; DO BUP RESTORE (let* ((new-test-dat (rmt:get-test-info-by-id run-id test-id)) (new-test-path (if (vector? new-test-dat ) (db:test-get-rundir new-test-dat) (begin (debug:print-error 0 *default-log-port* "unable to get data for run-id=" run-id ", test-id=" test-id) (exit 1)))) ;; new-test-path won't work - must use best-disk instead? Nope, new-test-path but tack on /.. (bup-restore-params (list "-d" archive-path "restore" "-C" (conc new-test-path "/..") archive-internal-path))) (debug:print-info 0 *default-log-port* "Restoring archived data to " new-test-physical-path " from archive in " archive-path " ... " archive-internal-path) (debug:print-info 0 *default-log-port* bup-exe " " (string-join bup-restore-params " ")) ;; (mutex-lock! bup-mutex) (run-n-wait bup-exe params: bup-restore-params print-cmd: #f) ;; (mutex-unlock! bup-mutex) (mt:test-set-state-status-by-id run-id test-id "COMPLETED" #f #f))) (debug:print-error 0 *default-log-port* "No archive path in the record for run-id=" run-id " test-id=" test-id)))))) (filter vector? tests)))) (define (common:get-youngest-test tests) (if (null? tests) #f (let ((res #f)) (for-each |
︙ | ︙ |
Modified common.scm from [6dfe1234b3] to [cd4f79ceff].
︙ | ︙ | |||
512 513 514 515 516 517 518 | (begin (debug:print-info 2 *default-log-port* "unable to rotate log " file ", probably handled by another process, this is safe to ignore.") (debug:print 2 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) ;; (print-call-chain (current-error-port)) ;; ) (let* ((fullname (conc "logs/" file)) (mod-time (file-modification-time fullname)) | | > > | > < | | > | 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 | (begin (debug:print-info 2 *default-log-port* "unable to rotate log " file ", probably handled by another process, this is safe to ignore.") (debug:print 2 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) ;; (print-call-chain (current-error-port)) ;; ) (let* ((fullname (conc "logs/" file)) (mod-time (file-modification-time fullname)) (file-age (- (current-seconds) mod-time)) (file-old (> file-age (* 48 60 60))) (file-big (> (file-size fullname) 200000))) (hash-table-set! all-files file mod-time) (if (or (and (string-match "^.*.log" file) file-old file-big) (and (string-match "^server-.*.log" file) file-old)) (let ((gzfile (conc fullname ".gz"))) (if (common:file-exists? gzfile) (begin (debug:print-info 0 *default-log-port* "removing " gzfile) (delete-file* gzfile) (hash-table-delete! all-files gzfile) ;; needed? )) (debug:print-info 0 *default-log-port* "compressing " file) (system (conc "gzip " fullname)) (inc-stat "gzipped") (hash-table-set! all-files (conc file ".gz") file-age) ;; add the .gz file and remove the base file (hash-table-delete! all-files file) ) (if (and (> file-age (* (string->number (or (configf:lookup *configdat* "setup" "log-expire-days") "30")) 24 3600)) (file-exists? fullname)) ;; just in case it was gzipped - will get it next time (handle-exceptions exn #f (if (directory? fullname) (begin (debug:print-error 0 *default-log-port* fullname " in logs directory is a directory! Cannot rotate it, it is best to not put subdirectories in the logs dir.") (inc-stat "directories")) |
︙ | ︙ | |||
900 901 902 903 904 905 906 | (if val val default))) (define (assoc/default key lst . default) (let ((res (assoc key lst))) (if res (cadr res)(if (null? default) #f (car default))))) (define (common:get-testsuite-name) | > > > | > > | 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 | (if val val default))) (define (assoc/default key lst . default) (let ((res (assoc key lst))) (if res (cadr res)(if (null? default) #f (car default))))) (define (common:get-testsuite-name) (or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description. (configf:lookup *configdat* "setup" "testsuite" ) (getenv "MT_TESTSUITE_NAME") (if (string? *toppath* ) (pathname-file *toppath*) #f))) ;; (pathname-file (current-directory))))) ;; safe getting of toppath (define (common:get-toppath areapath) (or *toppath* (if areapath (begin (set! *toppath* areapath) |
︙ | ︙ | |||
1650 1651 1652 1653 1654 1655 1656 | (if (> curr-rownum rownum) curr-rownum rownum) (if (> curr-colnum colnum) curr-colnum colnum) )))))) ;; if it looks like a number -> convert it to a number, else return it ;; (define (common:lazy-convert inval) | > | > > > > > > > > | > > > | 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 | (if (> curr-rownum rownum) curr-rownum rownum) (if (> curr-colnum colnum) curr-colnum colnum) )))))) ;; if it looks like a number -> convert it to a number, else return it ;; (define (common:lazy-convert inval) (let* ((as-num (if (string? inval)(string->number inval) #f))) (or as-num inval))) ;; convert string a=1; b=2; c=a silly thing; d= ;; to '((a . 1)(b . 2)(c . "a silly thing")(d . "")) ;; (define (common: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 (common:lazy-convert inval) inval)))) (else f)))) val-list) '()))) ;;====================================================================== ;; S Y S T E M S T U F F ;;====================================================================== ;; lazy-safe get file mod time. on any error (file not existing etc.) return 0 ;; |
︙ | ︙ |
Modified commonmod.scm from [3a4a140a66] to [9423abd515].
︙ | ︙ | |||
32 33 34 35 36 37 38 39 40 41 42 43 44 45 | ;; CONTENTS ;; ;; config file utils ;; misc conversion, data manipulation functions ;; testsuite and area utilites ;; ;;====================================================================== ;;====================================================================== ;; config file utils ;;====================================================================== (define (lookup cfgdat section var) (if (hash-table? cfgdat) | > > > > > > > > > > | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | ;; CONTENTS ;; ;; config file utils ;; misc conversion, data manipulation functions ;; testsuite and area utilites ;; ;;====================================================================== (include "megatest-version.scm") (include "megatest-fossil-hash.scm") (define (get-full-version) (conc megatest-version "-" megatest-fossil-hash)) (define (version-signature) (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) ;;====================================================================== ;; config file utils ;;====================================================================== (define (lookup cfgdat section var) (if (hash-table? cfgdat) |
︙ | ︙ |
Modified configf.scm from [4e4d952787] to [f6229df901].
1 2 3 4 5 6 7 8 9 10 11 12 13 | ;;====================================================================== ;; Copyright 2006-2012, 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 | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | ;;====================================================================== ;; Copyright 2006-2012, Matthew Welland. ;; ;; This file is part of Megatest. ;; ;; Megatest is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; Megatest is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== ;;====================================================================== |
︙ | ︙ | |||
190 191 192 193 194 195 196 | ;; (not (eq? allow-processing 'return-string))) ((#t #f) (configf:process-line inl ht allow-processing)) ((return-string) inl) (else (configf:process-line inl ht allow-processing))))) | | | | 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 | ;; (not (eq? allow-processing 'return-string))) ((#t #f) (configf:process-line inl ht allow-processing)) ((return-string) inl) (else (configf:process-line inl ht allow-processing))))) (if (and (string? res) ;; must set to "no" to force NOT trimming trailing spaces (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "yes") "no"))) (string-substitute "\\s+$" "" res) res)))))) (define (configf:cfgdat->env-alist section cfgdat-ht allow-system) (filter (lambda (pair) (let* ((var (car pair)) |
︙ | ︙ | |||
499 500 501 502 503 504 505 506 507 508 509 510 511 512 | (if (not (null? field-names))(keys:target-set-args field-names target #f)))))) (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: (list (cons "^fields$" set-fields)) #f)))) (if toppath (change-directory curr-dir)) (list configdat toppath configfile fname)))) ;; use to have definitive setting: ;; [foo] ;; var yes ;; ;; (configf:var-is? cfgdat "foo" "var" "yes") => #t ;; | > > > > > > > > > > > > | 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 | (if (not (null? field-names))(keys:target-set-args field-names target #f)))))) (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: (list (cons "^fields$" set-fields)) #f)))) (if toppath (change-directory curr-dir)) (list configdat toppath configfile fname)))) (define (configf: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 ;; ;; (configf:var-is? cfgdat "foo" "var" "yes") => #t ;; |
︙ | ︙ |
Modified dashboard.scm from [683033e99e] to [0d4ccbb40e].
︙ | ︙ | |||
42 43 44 45 46 47 48 | (declare (uses dashboard-guimonitor)) (declare (uses tree)) (declare (uses dcommon)) (declare (uses dashboard-context-menu)) (declare (uses vg)) (declare (uses subrun)) ;; (declare (uses dashboard-main)) | < > | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | (declare (uses dashboard-guimonitor)) (declare (uses tree)) (declare (uses dcommon)) (declare (uses dashboard-context-menu)) (declare (uses vg)) (declare (uses subrun)) ;; (declare (uses dashboard-main)) (declare (uses mt)) (declare (uses dbmod)) (import (prefix dbmod dbmod:)) (declare (uses commonmod)) (import (prefix commonmod cmod:)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") (include "task_records.scm") (include "megatest-version.scm") (include "megatest-fossil-hash.scm") (include "vg_records.scm") (define help (conc "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright (C) Matt Welland 2012-2017 |
︙ | ︙ | |||
3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 | (dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat)) (dboard:commondat-curr-tab-num-set! commondat 0) (dboard:commondat-add-updater commondat (lambda () (dashboard:runs-tab-updater commondat 1)) tab-num: 1) (dboard:commondat-add-updater commondat (lambda () (dashboard:runs-tab-updater commondat 1)) tab-num: 2) (iup:callback-set! *tim* "ACTION_CB" | > | 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 | (dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat)) (dboard:commondat-curr-tab-num-set! commondat 0) (dboard:commondat-add-updater commondat (lambda () (dashboard:runs-tab-updater commondat 1)) tab-num: 1) ;; may not want this alive (manually merged it from v1.66) (dboard:commondat-add-updater commondat (lambda () (dashboard:runs-tab-updater commondat 1)) tab-num: 2) (iup:callback-set! *tim* "ACTION_CB" |
︙ | ︙ |
Modified db.scm from [1abf27c71c] to [f30ded65d6].
︙ | ︙ | |||
56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 | (tmpdb #f) (dbstack #f) ;; stack for tmp db handles, do not initialize with a stack (mtdb #f) (refndb #f) (homehost #f) ;; not used yet (on-homehost #f) ;; not used yet (read-only #f) ) ;; goal is to converge on one struct for an area but for now it is too confusing ;; record for keeping state,status and count for doing roll-ups in ;; iterated tests ;; (defstruct dbr:counts (state #f) (status #f) (count 0)) ;;====================================================================== ;; SQLITE3 HELPERS ;;====================================================================== (define (db:general-sqlite-error-dump exn stmt . params) (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; RADT ... how does this work? | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 | (tmpdb #f) (dbstack #f) ;; stack for tmp db handles, do not initialize with a stack (mtdb #f) (refndb #f) (homehost #f) ;; not used yet (on-homehost #f) ;; not used yet (read-only #f) (stmt-cache (make-hash-table)) ) ;; goal is to converge on one struct for an area but for now it is too confusing ;; record for keeping state,status and count for doing roll-ups in ;; iterated tests ;; (defstruct dbr:counts (state #f) (status #f) (count 0)) ;;====================================================================== ;; alist-of-alists ;;====================================================================== ;; ;; (define (db:aa-set! dat key1 key2 val) ;; (let loop (( ;;====================================================================== ;; hash of hashs ;;====================================================================== (define (db:hoh-set! dat key1 key2 val) (let* ((subhash (hash-table-ref/default dat key1 #f))) (if subhash (hash-table-set! subhash key2 val) (begin (hash-table-set! dat key1 (make-hash-table)) (db:hoh-set! dat key1 key2 val))))) (define (db:hoh-get dat key1 key2) (let* ((subhash (hash-table-ref/default dat key1 #f))) (and subhash (hash-table-ref/default subhash key2 #f)))) (define (db:get-cache-stmth dbstruct db stmt) (let* ((stmt-cache (dbr:dbstruct-stmt-cache dbstruct)) (stmth (db:hoh-get stmt-cache db stmt))) (or stmth (let* ((newstmth (sqlite3:prepare db stmt))) (db:hoh-set! stmt-cache db stmt newstmth) newstmth)))) ;;====================================================================== ;; SQLITE3 HELPERS ;;====================================================================== (define (db:general-sqlite-error-dump exn stmt . params) (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; RADT ... how does this work? |
︙ | ︙ | |||
413 414 415 416 417 418 419 | (db:sync-tables (db:sync-all-tables-list dbstruct) update_info tmpdb refndb mtdb)) (mutex-lock! *db-multi-sync-mutex*) (set! *db-last-sync* start-t) (set! *db-last-access* start-t) (mutex-unlock! *db-multi-sync-mutex*) (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb))) | | | > | | | | > | < < | | | 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 | (db:sync-tables (db:sync-all-tables-list dbstruct) update_info tmpdb refndb mtdb)) (mutex-lock! *db-multi-sync-mutex*) (set! *db-last-sync* start-t) (set! *db-last-access* start-t) (mutex-unlock! *db-multi-sync-mutex*) (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb))) (define (db:safely-close-sqlite3-db db stmt-cache #!key (try-num 3)) (if (<= try-num 0) #f (handle-exceptions exn (begin (thread-sleep! 3) (sqlite3:interrupt! db) (db:safely-close-sqlite3-db db try-num: (- try-num 1))) (if (sqlite3:database? db) (let* ((stmts (hash-table-ref/default stmt-cache db #f))) (if stmts (map sqlite3:finalize! (hash-table-values stmts))) (sqlite3:finalize! db) #t) #f)))) ;; close all opened run-id dbs (define (db:close-all dbstruct) (if (dbr:dbstruct? dbstruct) (handle-exceptions exn (begin (debug:print 0 *default-log-port* "WARNING: Finalizing failed, " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain *default-log-port*)) ;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server. (let ((tdbs (map db:dbdat-get-db (stack->list (dbr:dbstruct-dbstack dbstruct)))) (mdb (db:dbdat-get-db (dbr:dbstruct-mtdb dbstruct))) (rdb (db:dbdat-get-db (dbr:dbstruct-refndb dbstruct))) (stmt-cache (dbr:dbstruct-stmt-cache dbstruct))) (map (lambda (db) (db:safely-close-sqlite3-db stmt-cache db)) tdbs) (db:safely-close-sqlite3-db stmt-cache mdb) ;; (if (sqlite3:database? mdb) (sqlite3:finalize! mdb)) (db:safely-close-sqlite3-db stmt-cache rdb))))) ;; (if (sqlite3:database? rdb) (sqlite3:finalize! rdb)))))) ;; (let ((locdbs (dbr:dbstruct-locdbs dbstruct))) ;; (if (hash-table? locdbs) ;; (for-each (lambda (run-id) ;; (db:close-run-db dbstruct run-id)) ;; (hash-table-keys locdbs))))) |
︙ | ︙ | |||
530 531 532 533 534 535 536 537 538 539 540 541 542 543 | '("fieldtype" #f)) (list "metadat" '("var" #f) '("val" #f)) (append (list "runs" '("id" #f)) (map (lambda (k)(list k #f)) (append keys (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update")))) (list "test_meta" '("id" #f) '("testname" #f) '("owner" #f) '("description" #f) '("reviewed" #f) '("iterated" #f) | > > > > > > > > > > > > > > > > | 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 | '("fieldtype" #f)) (list "metadat" '("var" #f) '("val" #f)) (append (list "runs" '("id" #f)) (map (lambda (k)(list k #f)) (append keys (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update")))) (list "archive_disks" '("id" #f) '("archive_area_name" #f) '("disk_path" #f) '("last_df" #f) '("last_df_time" #f) '("creation_time" #f)) (list "archive_blocks" '("id" #f) '("archive_disk_id" #f) '("disk_path" #f) '("last_du" #f) '("last_du_time" #f) '("creation_time" #f)) (list "test_meta" '("id" #f) '("testname" #f) '("owner" #f) '("description" #f) '("reviewed" #f) '("iterated" #f) |
︙ | ︙ | |||
694 695 696 697 698 699 700 | (use-last-update (cond ((and has-last-update (member "last_update" fields)) #t) ;; if given a number, just use it for all fields ((number? last-update) #f) ;; if not matched first entry then ignore last-update for this table ((and (pair? last-update) (member (car last-update) ;; last-update field name | | > | | 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 | (use-last-update (cond ((and has-last-update (member "last_update" fields)) #t) ;; if given a number, just use it for all fields ((number? last-update) #f) ;; if not matched first entry then ignore last-update for this table ((and (pair? last-update) (member (car last-update) ;; last-update field name (map car fields))) #t) (last-update (debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair or a number, received: " last-update);; found in fields #f) (else #f))) (last-update-value (if use-last-update ;; no need to check for has-last-update - it is already accounted for (if (number? last-update) last-update (cdr last-update)) |
︙ | ︙ | |||
726 727 728 729 730 731 732 | " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );")) (fromdat '()) (fromdats '()) (totrecords 0) (batch-len (string->number (or (configf:lookup *configdat* "sync" "batchsize") "100"))) (todat (make-hash-table)) (count 0) | | | 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 | " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );")) (fromdat '()) (fromdats '()) (totrecords 0) (batch-len (string->number (or (configf:lookup *configdat* "sync" "batchsize") "100"))) (todat (make-hash-table)) (count 0) (field-names (map car fields)) (delay-handicap (string->number (or (configf:lookup *configdat* "sync" "delay-handicap") "0"))) ) ;; set up the field->num table (for-each (lambda (field) (hash-table-set! field->num field count) |
︙ | ︙ | |||
773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 | (debug:print-info 0 *default-log-port* "synthetic sync delay of "delay-handicap" seconds completed") ) ;; first pass implementation, just insert all changed rows (for-each (lambda (targdb) (let* ((db (db:dbdat-get-db targdb)) (stmth (sqlite3:prepare db full-ins))) (db:delay-if-busy targdb) ;; NO WAITING (for-each (lambda (fromdat-lst) (sqlite3:with-transaction db (lambda () (for-each ;; (lambda (fromrow) | > > > > > > > | 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 | (debug:print-info 0 *default-log-port* "synthetic sync delay of "delay-handicap" seconds completed") ) ;; first pass implementation, just insert all changed rows (for-each (lambda (targdb) (let* ((db (db:dbdat-get-db targdb)) (drp-trigger (if (member "last_update" field-names) (db:drop-trigger db tablename) #f)) (is-trigger-dropped (if (member "last_update" field-names) (db:is-trigger-dropped db tablename) #f)) (stmth (sqlite3:prepare db full-ins))) (db:delay-if-busy targdb) ;; NO WAITING (if (member "last_update" field-names) (debug:print-info 3 *default-log-port* "is-trigger-dropped: " is-trigger-dropped)) (for-each (lambda (fromdat-lst) (sqlite3:with-transaction db (lambda () (for-each ;; (lambda (fromrow) |
︙ | ︙ | |||
796 797 798 799 800 801 802 | (if (and same (< i (- num-fields 1))) (loop (+ i 1)))) (if (not same) (begin (apply sqlite3:execute stmth (vector->list fromrow)) (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0))))))) | | < | > > | 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 | (if (and same (< i (- num-fields 1))) (loop (+ i 1)))) (if (not same) (begin (apply sqlite3:execute stmth (vector->list fromrow)) (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0))))))) fromdat-lst)))) fromdats) (sqlite3:finalize! stmth) (if (member "last_update" field-names) (db:create-trigger db tablename)))) (append (list todb) slave-dbs)))) tbls) (let* ((runtime (- (current-milliseconds) start-time)) (should-print (or (debug:debug-mode 12) (common:low-noise-print 120 "db sync" (> runtime 500))))) ;; low and high sync times treated as separate. (if should-print (debug:print 3 *default-log-port* "INFO: db sync, total run time " runtime " ms")) (for-each |
︙ | ︙ | |||
1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 | (apply open-run-close-no-exception-handling proc idb params))) ;; (define open-run-close #;(define open-run-close open-run-close-exception-handling) ;; open-run-close-no-exception-handling ;; open-run-close-exception-handling) ;;) (define (db:initialize-main-db dbdat) (when (not *configinfo*) (launch:setup)) ;; added because Elena was getting stack dump because *configinfo* below was #f. (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... (keys (keys:config-get-fields configdat)) (havekeys (> (length keys) 0)) | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 | (apply open-run-close-no-exception-handling proc idb params))) ;; (define open-run-close #;(define open-run-close open-run-close-exception-handling) ;; open-run-close-no-exception-handling ;; open-run-close-exception-handling) ;;) (define db:trigger-list (list (list "update_runs_trigger" "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs FOR EACH ROW BEGIN UPDATE runs SET last_update=(strftime('%s','now')) WHERE id=old.id; END;" ) (list "update_run_stats_trigger" "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats FOR EACH ROW BEGIN UPDATE run_stats SET last_update=(strftime('%s','now')) WHERE id=old.id; END;" ) (list "update_tests_trigger" "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests FOR EACH ROW BEGIN UPDATE tests SET last_update=(strftime('%s','now')) WHERE id=old.id; END;" ) (list "update_teststeps_trigger" "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps FOR EACH ROW BEGIN UPDATE test_steps SET last_update=(strftime('%s','now')) WHERE id=old.id; END;" ) (list "update_test_data_trigger" "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data FOR EACH ROW BEGIN UPDATE test_data SET last_update=(strftime('%s','now')) WHERE id=old.id; END;" ))) (define (db:create-all-triggers dbstruct) (db:with-db dbstruct #f #f (lambda (db) (db:create-triggers db)))) (define (db:create-triggers db) (for-each (lambda (key) (sqlite3:execute db (cadr key))) db:trigger-list)) (define (db:drop-all-triggers dbstruct) (db:with-db dbstruct #f #f (lambda (db) (db:drop-triggers db)))) (define (db:is-trigger-dropped db tbl-name) (let* ((trigger-name (if (equal? tbl-name "test_steps") "update_teststeps_trigger" (conc "update_" tbl-name "_trigger")))) (sqlite3:for-each-row (lambda (name) ;(print name) (set! res (vector name))) db "select name from sqlite_master where type = 'trigger' ;" ))) (define (db:drop-triggers db) (for-each (lambda (key) (sqlite3:execute db (conc "drop trigger " (car key)))) db:trigger-list)) (define (db:drop-trigger db tbl-name) (let* ((trigger-name (if (equal? tbl-name "test_steps") "update_teststeps_trigger" (conc "update_" tbl-name "_trigger")))) (for-each (lambda (key) (if (equal? (car key) trigger-name) (sqlite3:execute db (conc "drop trigger " trigger-name)))) db:trigger-list))) (define (db:create-trigger db tbl-name) (let* ((trigger-name (if (equal? tbl-name "test_steps") "update_teststeps_trigger" (conc "update_" tbl-name "_trigger")))) (for-each (lambda (key) (if (equal? (car key) trigger-name) (sqlite3:execute db (cadr key)))) db:trigger-list))) (define (db:initialize-main-db dbdat) (when (not *configinfo*) (launch:setup)) ;; added because Elena was getting stack dump because *configinfo* below was #f. (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... (keys (keys:config-get-fields configdat)) (havekeys (> (length keys) 0)) |
︙ | ︙ | |||
1199 1200 1201 1202 1203 1204 1205 | owner TEXT DEFAULT '', event_time TIMESTAMP DEFAULT (strftime('%s','now')), comment TEXT DEFAULT '', fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));")) | > | | | | | | > | | | | | | | 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 | owner TEXT DEFAULT '', event_time TIMESTAMP DEFAULT (strftime('%s','now')), comment TEXT DEFAULT '', fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));")) ;; All triggers created at once in end ;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs ;; FOR EACH ROW ;; BEGIN ;; UPDATE runs SET last_update=(strftime('%s','now')) ;; WHERE id=old.id; ;; END;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS run_stats ( id INTEGER PRIMARY KEY, run_id INTEGER, state TEXT, status TEXT, count INTEGER, last_update INTEGER DEFAULT (strftime('%s','now')))") ;; All triggers created at once in end ;; (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats ;; FOR EACH ROW ;; BEGIN ;; UPDATE run_stats SET last_update=(strftime('%s','now')) ;; WHERE id=old.id; ;; END;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta ( id INTEGER PRIMARY KEY, testname TEXT DEFAULT '', author TEXT DEFAULT '', owner TEXT DEFAULT '', description TEXT DEFAULT '', reviewed TIMESTAMP, |
︙ | ︙ | |||
1317 1318 1319 1320 1321 1322 1323 | last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));") ;; deprecated -- (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path, uname);") (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_run_id_index ON tests (run_id);") ;; new (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_testname_index ON tests (testname,item_path);") ;; new (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_state_status_index ON tests (state, status); ") ;; new | | > | | | | | | > | | | | | | > | | | | | | > > | 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 | last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));") ;; deprecated -- (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path, uname);") (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_run_id_index ON tests (run_id);") ;; new (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_testname_index ON tests (testname,item_path);") ;; new (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_state_status_index ON tests (state, status); ") ;; new ;; All triggers created at once in end ;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests ;; FOR EACH ROW ;; BEGIN ;; UPDATE tests SET last_update=(strftime('%s','now')) ;; WHERE id=old.id; ;; END;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps (id INTEGER PRIMARY KEY, test_id INTEGER, stepname TEXT, state TEXT DEFAULT 'NOT_STARTED', status TEXT DEFAULT 'n/a', event_time TIMESTAMP, comment TEXT DEFAULT '', logfile TEXT DEFAULT '', last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));") (sqlite3:execute db "CREATE INDEX IF NOT EXISTS teststeps_index ON tests (run_id, testname, item_path);") ;; All triggers created at once in end ;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps ;; FOR EACH ROW ;; BEGIN ;; UPDATE test_steps SET last_update=(strftime('%s','now')) ;; WHERE id=old.id; ;; END;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, test_id INTEGER, category TEXT DEFAULT '', variable TEXT, value REAL, expected REAL, tol REAL, units TEXT, comment TEXT DEFAULT '', status TEXT DEFAULT 'n/a', type TEXT DEFAULT '', last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));") (sqlite3:execute db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);") ;; All triggers created at once in end ;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data ;; FOR EACH ROW ;; BEGIN ;; UPDATE test_data SET last_update=(strftime('%s','now')) ;; WHERE id=old.id; ;; END;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat ( id INTEGER PRIMARY KEY, test_id INTEGER, update_time TIMESTAMP, cpuload INTEGER DEFAULT -1, diskfree INTEGER DEFAULT -1, diskusage INTGER DEFAULT -1, run_duration INTEGER DEFAULT 0);") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archives ( id INTEGER PRIMARY KEY, test_id INTEGER, state TEXT DEFAULT 'new', status TEXT DEFAULT 'n/a', archive_type TEXT DEFAULT 'bup', du INTEGER, archive_path TEXT);"))) (print "creating trigges from init") (db:create-triggers db) db)) ;; ) ;;====================================================================== ;; A R C H I V E S ;;====================================================================== ;; dneeded is minimum space needed, scan for existing archives that |
︙ | ︙ | |||
1605 1606 1607 1608 1609 1610 1611 1612 | (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") (if (and (null? incompleted) (null? oldlaunched) (null? toplevels)) #f #t))))) | < < < < < < < | < | | | | | | < < < < < | 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 | (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") (if (and (null? incompleted) (null? oldlaunched) (null? toplevels)) #f #t))))) (define (db:get-status-from-final-status-file run-dir) (let ((infile (conc run-dir "/.final-status"))) ;; first verify we are able to write the output file (if (not (file-read-access? infile)) (begin (debug:print 0 *default-log-port* "ERROR: cannot read " infile) (debug:print 0 *default-log-port* "ERROR: run-dir is " run-dir) #f ) (with-input-from-file infile read-lines) ))) ;; select end_time-now from ;; (select testname,item_path,event_time+run_duration as ;; end_time,strftime('%s','now') as now from tests where state in ;; ('RUNNING','REMOTEHOSTSTART','LAUNCHED')); (define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime) |
︙ | ︙ | |||
1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 | (let ((is-alive (launch:is-test-alive host pid))) (if is-alive (debug:print 0 *default-log-port* "INFO: test " test-id " on host " host " has a process on pid " pid ", NOT setting to DEAD.") (begin (debug:print 0 *default-log-port* "INFO: test " test-id " final state/status is not COMPLETED/PASS. It is " result) (db:set-state-status-and-roll-up-items dbstruct run-id test-id 'foo "COMPLETED" "DEAD" "Test stopped responding while in RUNNING or REMOTEHOSTSTART; presumed dead."))))))) all-ids) ;;call end of eud of run detection for posthook (launch:end-of-run-check run-id) ))))))) ;; ALL REPLACED BY THE BLOCK ABOVE | > > | 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 | (let ((is-alive (launch:is-test-alive host pid))) (if is-alive (debug:print 0 *default-log-port* "INFO: test " test-id " on host " host " has a process on pid " pid ", NOT setting to DEAD.") (begin (debug:print 0 *default-log-port* "INFO: test " test-id " final state/status is not COMPLETED/PASS. It is " result) (db:set-state-status-and-roll-up-items dbstruct run-id test-id 'foo "COMPLETED" "DEAD" "Test stopped responding while in RUNNING or REMOTEHOSTSTART; presumed dead."))))))) ;; call end of eud of run detection for posthook - from merge, is it needed? ;; (launch:end-of-run-check run-id) all-ids) ;;call end of eud of run detection for posthook (launch:end-of-run-check run-id) ))))))) ;; ALL REPLACED BY THE BLOCK ABOVE |
︙ | ︙ | |||
1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 | "SELECT val FROM metadat WHERE var=?;" var) ;; convert to number if can (if (string? res) (let ((valnum (string->number res))) (if valnum (set! res valnum)))) res)))) ;; This was part of db:get-var. It was used to estimate the load on ;; the database files. ;; ;; scale by 10, average with current value. ;; (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms) ;; (if throttle throttle 0.01))) ;; 2)) ;; (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit ;; (begin ;; (debug:print-info 4 *default-log-port* "launch throttle factor=" *global-delta*) ;; (set! *last-global-delta-printed* *global-delta*))) (define (db:set-var dbstruct var val) (db:with-db dbstruct #f #t (lambda (db) (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)))) (define (db:del-var dbstruct var) (db:with-db dbstruct #f #t (lambda (db) (sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var)))) ;;====================================================================== ;; no-sync.db - small bits of data to be shared between servers | > > > > > > > > > > > > > > > | 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 | "SELECT val FROM metadat WHERE var=?;" var) ;; convert to number if can (if (string? res) (let ((valnum (string->number res))) (if valnum (set! res valnum)))) res)))) (define (db:inc-var dbstruct var) (db:with-db dbstruct #f #t (lambda (db) (sqlite3:execute db "UPDATE metadat SET val=val+1 WHERE var=?;" var)))) (define (db:dec-var dbstruct var) (db:with-db dbstruct #f #t (lambda (db) (sqlite3:execute db "UPDATE metadat SET val=val-1 WHERE var=?;" var)))) ;; This was part of db:get-var. It was used to estimate the load on ;; the database files. ;; ;; scale by 10, average with current value. ;; (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms) ;; (if throttle throttle 0.01))) ;; 2)) ;; (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit ;; (begin ;; (debug:print-info 4 *default-log-port* "launch throttle factor=" *global-delta*) ;; (set! *last-global-delta-printed* *global-delta*))) (define (db:set-var dbstruct var val) (db:with-db dbstruct #f #t (lambda (db) (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)))) (define (db:add-var dbstruct var val) (db:with-db dbstruct #f #t (lambda (db) (sqlite3:execute db "UPDATE metadat SET val=val+? WHERE var=?;" val var)))) (define (db:del-var dbstruct var) (db:with-db dbstruct #f #t (lambda (db) (sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var)))) ;;====================================================================== ;; no-sync.db - small bits of data to be shared between servers |
︙ | ︙ | |||
2852 2853 2854 2855 2856 2857 2858 | " "))) (if sort-order sort-order " ") (if limit (conc " LIMIT " limit) " ") (if offset (conc " OFFSET " offset) " ") ";" ))) (debug:print-info 8 *default-log-port* "db:get-tests-for-run run-id=" run-id ", qry=" qry) | | | > > | > | | < > > | | | | | | | > > > > > | > > > | > > > | | | > | | > | | | | | < < > > | < | 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 | " "))) (if sort-order sort-order " ") (if limit (conc " LIMIT " limit) " ") (if offset (conc " OFFSET " offset) " ") ";" ))) (debug:print-info 8 *default-log-port* "db:get-tests-for-run run-id=" run-id ", qry=" qry) (let* ((res (db:with-db dbstruct run-id #f (lambda (db) ;; (let* ((stmth (db:get-cache-stmth dbstruct db qry))) ;; due to use of last-update we can't efficiently cache this query (reverse (sqlite3:fold-row (lambda (res . row) ;; id run-id testname state status event-time host cpuload ;; diskfree uname rundir item-path run-duration final-logf comment) (cons (list->vector row) res)) '() db qry ;; stmth (or run-id 1) ;; 1 > 0 , for the case where we are seeking tests matching criteral for all runs )))))) (case qryvals ((shortlist)(map db:test-short-record->norm res)) ((#f) res) (else res))))) (define (db:test-short-record->norm inrec) ;; "id,run_id,testname,item_path,state,status" ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment (vector (vector-ref inrec 0) ;; id (vector-ref inrec 1) ;; run_id (vector-ref inrec 2) ;; testname (vector-ref inrec 4) ;; state (vector-ref inrec 5) ;; status -1 "" -1 -1 "" "-" (vector-ref inrec 3) ;; item-path -1 "-" "-")) ;; ;; 1. cache tests-match-qry ;; 2. compile qry and store in hash ;; 3. convert for-each-row to fold ;; (define (db:get-tests-for-run-state-status dbstruct run-id testpatt) (db:with-db dbstruct run-id #f (lambda (db) (let* ((res '()) (stmt-cache (dbr:dbstruct-stmt-cache dbstruct)) (stmth (let* ((sh (db:hoh-get stmt-cache db testpatt))) (or sh (let* ((tests-match-qry (tests:match->sqlqry testpatt)) (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " (if tests-match-qry (conc " AND (" tests-match-qry ") ") ""))) (newsh (sqlite3:prepare db qry))) (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry) (db:hoh-set! stmt-cache db testpatt newsh) newsh))))) (reverse (sqlite3:fold-row (lambda (res id testname item-path state status) ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res)) '() stmth run-id)))))) (define (db:get-tests-for-run-state-status dbstruct run-id testpatt #!optional (last-update 0)) (let* ((res '()) (tests-match-qry (tests:match->sqlqry testpatt)) (qry (conc "SELECT id,testname,item_path,state,status,event_time,run_duration FROM tests WHERE run_id=? " " AND last_update > ? " (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") |
︙ | ︙ | |||
3038 3039 3040 3041 3042 3043 3044 | (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id)) (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment ;; (sdb:qry 'getid newcomment) test-id)))))) (mt:process-triggers dbstruct run-id test-id newstate newstatus)) ;; NEW BEHAVIOR: Count tests running in all runs! ;; | | > > > > | < < < < < < | > > > | | | | | > | < < > > | < < | | 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 | (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id)) (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment ;; (sdb:qry 'getid newcomment) test-id)))))) (mt:process-triggers dbstruct run-id test-id newstate newstatus)) ;; NEW BEHAVIOR: Count tests running in all runs! ;; (define (db:get-count-tests-running dbstruct run-id fastmode) (let* ((qry (if fastmode "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND NOT (uname = 'n/a' AND item_path = '') LIMIT 1;" "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND NOT (uname = 'n/a' AND item_path = '');"))) (db:with-db dbstruct run-id #f (lambda (db) (let* ((stmth (db:get-cache-stmth dbstruct db qry))) (sqlite3:first-result stmth)))))) ;; NEW BEHAVIOR: Count tests running in only one run! ;; (define (db:get-count-tests-actually-running dbstruct run-id) (db:with-db dbstruct run-id #f (lambda (db) (sqlite3:first-result db ;; WARNING BUG EDIT ME - merged from v1.55 - not sure what is right here ... ;; "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id NOT IN (SELECT id FROM runs WHERE state='deleted') AND NOT (uname = 'n/a' AND item_path = '');") "SELECT count(id) FROM tests WHERE state in ('RUNNING','REMOTEHOSTSTART','LAUNCHED') AND run_id=?;" run-id)))) ;; NOT IN (SELECT id FROM runs WHERE state='deleted');") ;; NEW BEHAVIOR: Look only at single run with run-id ;; ;; (define (db:get-running-stats dbstruct run-id) (define (db:get-count-tests-running-for-run-id dbstruct run-id fastmode) (let* ((qry (if fastmode "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? LIMIT 1;" "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;"))) (db:with-db dbstruct run-id #f (lambda (db) (let* ((stmth (db:get-cache-stmth dbstruct db qry))) (sqlite3:first-result stmth run-id)))))) ;; For a given testname how many items are running? Used to determine ;; probability for regenerating html ;; (define (db:get-count-tests-running-for-testname dbstruct run-id testname) (db:with-db dbstruct run-id #f (lambda (db) (let* ((stmt "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '') AND testname=?;") (stmth (db:get-cache-stmth dbstruct db stmt))) (sqlite3:first-result stmth run-id testname))))) (define (db:get-not-completed-cnt dbstruct run-id) (db:with-db dbstruct run-id #f (lambda (db) |
︙ | ︙ | |||
3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 | indx (if (null? tal) #f (loop (car tal)(cdr tal)(+ indx 1))))))) (define db:test-record-qry-selector (string-intersperse db:test-record-fields ",")) ;; NOTE: Use db:test-get* to access records ;; NOTE: This needs rundir decoding? Decide, decode here or where used? For the moment decode where used. (define (db:get-all-tests-info-by-run-id dbstruct run-id) (let* ((res '())) (db:with-db dbstruct #f #f | > > > > > > | 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 | indx (if (null? tal) #f (loop (car tal)(cdr tal)(+ indx 1))))))) (define db:test-record-qry-selector (string-intersperse db:test-record-fields ",")) (define (db:update-tesdata-on-repilcate-db dbstruct old-lt new-lt) (db:with-db dbstruct #f #f (lambda (db) (sqlite3:execute db "UPDATE tests SET rundir= replace(rundir,?,?), shortdir=replace(shortdir,?,?);" old-lt new-lt old-lt new-lt)))) ;; NOTE: Use db:test-get* to access records ;; NOTE: This needs rundir decoding? Decide, decode here or where used? For the moment decode where used. (define (db:get-all-tests-info-by-run-id dbstruct run-id) (let* ((res '())) (db:with-db dbstruct #f #f |
︙ | ︙ | |||
3464 3465 3466 3467 3468 3469 3470 | test-id) (reverse res))))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== | | > | | | | | | | | | < | > | | < | 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 | test-id) (reverse res))))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== (define (db:get-data-info-by-id dbstruct test-data-id) (let* ((stmt "SELECT id,test_id, category, variable, value, expected, tol, units, comment, status, type, last_update FROM test_data WHERE id=? ORDER BY id ASC;")) ;; event_time DESC,id ASC; (db:with-db dbstruct #f #f (lambda (db) (let* ((stmth (db:get-cache-stmth dbstruct db stmt)) (res (sqlite3:fold-row (lambda (res id test-id category variable value expected tol units comment status type last-update) (vector id test-id category variable value expected tol units comment status type last-update)) (vector #f #f #f #f #f #f #f #f #f #f #f #f) stmth test-data-id))) res))))) ;; WARNING: Do NOT call this for the parent test on an iterated test ;; Roll up test_data pass/fail results ;; look at the test_data status field, ;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS. ;; if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored (define (db:test-data-rollup dbstruct run-id test-id status) |
︙ | ︙ | |||
3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 | db "SELECT state,status,count(id) FROM tests WHERE run_id=? GROUP BY state,status;" run-id ))))) test-count-recs)) ;; BBnote: db:get-all-state-status-counts-for-test returns dbr:counts object aggregating state and status of items of a given test, *not including rollup state/status* (define (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path item-state-in item-status-in) (let* ((test-info (db:get-test-info dbstruct run-id test-name item-path)) (item-state (or item-state-in (db:test-get-state test-info))) (item-status (or item-status-in (db:test-get-status test-info))) (other-items-count-recs (db:with-db dbstruct #f #f (lambda (db) | > > > | 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 | db "SELECT state,status,count(id) FROM tests WHERE run_id=? GROUP BY state,status;" run-id ))))) test-count-recs)) ;; BBnote: db:get-all-state-status-counts-for-test returns dbr:counts object aggregating state and status of items of a given test, *not including rollup state/status* ;; ;; NOTE: This is called within a transaction ;; (define (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path item-state-in item-status-in) (let* ((test-info (db:get-test-info dbstruct run-id test-name item-path)) (item-state (or item-state-in (db:test-get-state test-info))) (item-status (or item-status-in (db:test-get-status test-info))) (other-items-count-recs (db:with-db dbstruct #f #f (lambda (db) |
︙ | ︙ |
Modified dcommon.scm from [30bf3c6504] to [8eac2f387f].
︙ | ︙ | |||
23 24 25 26 27 28 29 | (import (prefix iup iup:)) (use canvas-draw) (import canvas-draw-iup) (use regex typed-records matchable) (declare (unit dcommon)) | < > | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | (import (prefix iup iup:)) (use canvas-draw) (import canvas-draw-iup) (use regex typed-records matchable) (declare (unit dcommon)) (declare (uses gutils)) (declare (uses db)) ;; (declare (uses synchash)) (include "megatest-version.scm") (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") (include "run_records.scm") ;; yes, this is non-ideal (define dashboard:update-summary-tab #f) |
︙ | ︙ | |||
635 636 637 638 639 640 641 | (numrows 1) (numcols 1)) (iup:attribute-set! stats-matrix "CLEARVALUE" "CONTENTS") (iup:attribute-set! stats-matrix "NUMCOL" max-col ) (iup:attribute-set! stats-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20 (iup:attribute-set! stats-matrix "NUMCOL_VISIBLE" max-col-vis) (iup:attribute-set! stats-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row)) | | | 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 | (numrows 1) (numcols 1)) (iup:attribute-set! stats-matrix "CLEARVALUE" "CONTENTS") (iup:attribute-set! stats-matrix "NUMCOL" max-col ) (iup:attribute-set! stats-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20 (iup:attribute-set! stats-matrix "NUMCOL_VISIBLE" max-col-vis) (iup:attribute-set! stats-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row)) ;;(print "row-indices: " row-indices " col-indices: " col-indices) ;; Row labels (for-each (lambda (ind) (let* ((name (car ind)) (num (cadr ind)) (key (conc num ":0"))) (if (not (equal? (iup:attribute stats-matrix key) name)) (begin |
︙ | ︙ |
Modified docs/manual/installation.txt from [93bb208a2d] to [55192787b7].
︙ | ︙ | |||
18 19 20 21 22 23 24 25 26 27 28 29 30 31 | Installation ------------ Dependencies ~~~~~~~~~~~~ Chicken scheme and a number of "eggs" are required for building Megatest. In the v1.66 and beyond assistance to create the build system is built into the Makefile. .Installation steps (overview) ------------------------------------- ./configure make chicken | > > > > | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 | Installation ------------ Dependencies ~~~~~~~~~~~~ Chicken scheme and a number of "eggs" are required for building Megatest. See the script installall.sh in the utils directory of the source distribution for an automated way to install everything needed for building Megatest on Linux. Megatest. In the v1.66 and beyond assistance to create the build system is built into the Makefile. .Installation steps (overview) ------------------------------------- ./configure make chicken |
︙ | ︙ |
Modified docs/manual/megatest_manual.html from [815cb0cf69] to [4c1fe80b6f].
1 2 3 4 | <!DOCTYPE html> <html lang="en"> <head> <meta http-equiv="Content-Type" content="text/html; charset=UTF-8"> | | | 1 2 3 4 5 6 7 8 9 10 11 12 | <!DOCTYPE html> <html lang="en"> <head> <meta http-equiv="Content-Type" content="text/html; charset=UTF-8"> <meta name="generator" content="AsciiDoc 8.6.7"> <title>The Megatest Users Manual</title> <style type="text/css"> /* Shared CSS for AsciiDoc xhtml11 and html5 backends */ /* Default font. */ body { font-family: Georgia,serif; |
︙ | ︙ | |||
82 83 84 85 86 87 88 | ul, ol, li > p { margin-top: 0; } ul > li { color: #aaa; } ul > li > * { color: black; } | | < < < < < < | 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 | ul, ol, li > p { margin-top: 0; } ul > li { color: #aaa; } ul > li > * { color: black; } pre { padding: 0; margin: 0; } #author { color: #527bbd; font-weight: bold; font-size: 1.1em; } #email { |
︙ | ︙ | |||
220 221 222 223 224 225 226 | div.exampleblock > div.content { border-left: 3px solid #dddddd; padding-left: 0.5em; } div.imageblock div.content { padding-left: 0; } | | | 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 | div.exampleblock > div.content { border-left: 3px solid #dddddd; padding-left: 0.5em; } div.imageblock div.content { padding-left: 0; } span.image img { border-style: none; } a.image:visited { color: white; } dl { margin-top: 0.8em; margin-bottom: 0.8em; } dt { |
︙ | ︙ | |||
415 416 417 418 419 420 421 422 423 424 425 426 427 428 | div.unbreakable { page-break-inside: avoid; } /* * xhtml11 specific * * */ div.tableblock { margin-top: 1.0em; margin-bottom: 1.5em; } div.tableblock > table { border: 3px solid #527bbd; | > > > > > > | 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 | div.unbreakable { page-break-inside: avoid; } /* * xhtml11 specific * * */ tt { font-family: "Courier New", Courier, monospace; font-size: inherit; color: navy; } div.tableblock { margin-top: 1.0em; margin-bottom: 1.5em; } div.tableblock > table { border: 3px solid #527bbd; |
︙ | ︙ | |||
448 449 450 451 452 453 454 455 456 457 458 459 460 461 | } /* * html5 specific * * */ table.tableblock { margin-top: 1.0em; margin-bottom: 1.5em; } thead, p.tableblock.header { font-weight: bold; | > > > > > > | 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 | } /* * html5 specific * * */ .monospaced { font-family: "Courier New", Courier, monospace; font-size: inherit; color: navy; } table.tableblock { margin-top: 1.0em; margin-bottom: 1.5em; } thead, p.tableblock.header { font-weight: bold; |
︙ | ︙ | |||
528 529 530 531 532 533 534 | body.manpage div.sectionbody { margin-left: 3em; } @media print { body.manpage div#toc { display: none; } } | < < | 534 535 536 537 538 539 540 541 542 543 544 545 546 547 | body.manpage div.sectionbody { margin-left: 3em; } @media print { body.manpage div#toc { display: none; } } @media screen { body { max-width: 50em; /* approximately 80 characters wide */ margin-left: 16em; } #toc { |
︙ | ︙ | |||
2326 2327 2328 2329 2330 2331 2332 | </div></div> </div> <div class="sect2"> <h3 id="_trim_trailing_spaces">Trim trailing spaces</h3> <div class="admonitionblock"> <table><tr> <td class="icon"> | | | 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 | </div></div> </div> <div class="sect2"> <h3 id="_trim_trailing_spaces">Trim trailing spaces</h3> <div class="admonitionblock"> <table><tr> <td class="icon"> <img src="/nfs/pdx/disks/ice.disk.002/icfadm/pkgs/asciidoc/8.6.7/images/icons/note.png" alt="Note"> </td> <td class="content">As of Megatest version v1.6548 trim-trailing-spaces defaults to yes.</td> </tr></table> </div> <div class="listingblock"> <div class="content monospaced"> <pre>[configf:settings trim-trailing-spaces no] |
︙ | ︙ | |||
2628 2629 2630 2631 2632 2633 2634 | <pre># A normal waiton waits for the prior tests to be COMPLETED # and PASS, CHECK or WAIVED waiton test1 test2</pre> </div></div> <div class="admonitionblock"> <table><tr> <td class="icon"> | | | 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 | <pre># A normal waiton waits for the prior tests to be COMPLETED # and PASS, CHECK or WAIVED waiton test1 test2</pre> </div></div> <div class="admonitionblock"> <table><tr> <td class="icon"> <img src="/nfs/pdx/disks/ice.disk.002/icfadm/pkgs/asciidoc/8.6.7/images/icons/note.png" alt="Note"> </td> <td class="content">Dynamic waiton lists must be capable of being calculated at the beginning of a run. This is because Megatest walks the tree of waitons to create the list of tests to execute.</td> </tr></table> </div> <div class="listingblock"> |
︙ | ︙ | |||
3133 3134 3135 3136 3137 3138 3139 | <div class="content monospaced"> <pre>[triggers] COMPLETED/ xterm -e bash -s --</pre> </div></div> <div class="admonitionblock"> <table><tr> <td class="icon"> | | | 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 | <div class="content monospaced"> <pre>[triggers] COMPLETED/ xterm -e bash -s --</pre> </div></div> <div class="admonitionblock"> <table><tr> <td class="icon"> <img src="/nfs/pdx/disks/ice.disk.002/icfadm/pkgs/asciidoc/8.6.7/images/icons/note.png" alt="Note"> </td> <td class="content">There is a trailing space after the double-dash</td> </tr></table> </div> <div class="paragraph"><p>There are a number of environment variables available to the trigger script but since triggers can be called in various contexts not all variables are available at all times. The trigger script should check for the variable and |
︙ | ︙ | |||
3432 3433 3434 3435 3436 3437 3438 | </div> </div> </div> <div id="footnotes"><hr></div> <div id="footer"> <div id="footer-text"> Version 1.5<br> | | < | 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 | </div> </div> </div> <div id="footnotes"><hr></div> <div id="footer"> <div id="footer-text"> Version 1.5<br> Last updated 2020-06-29 08:09:27 PDT </div> </div> </body> </html> |
Modified docs/manual/plan.txt from [b8930eff65] to [b4fe19be84].
1 2 3 4 5 6 7 | // 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. // | > > > | 1 2 3 4 5 6 7 8 9 10 | Road Map -------- // 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. // |
︙ | ︙ |
Modified docs/manual/server.png from [da85cb6703] to [ae7d7ee58e].
cannot compute difference between binary files
Added emacs.config version [f8d660afb3].
> > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | ;; Indenting module body code at column 0 (defun scheme-module-indent (state indent-point normal-indent) 0) (put 'module 'scheme-indent-function 'scheme-module-indent) (put 'and-let* 'scheme-indent-function 1) (put 'parameterize 'scheme-indent-function 1) (put 'handle-exceptions 'scheme-indent-function 1) (put 'when 'scheme-indent-function 1) (put 'unless 'scheme-indent-function 1) (put 'match 'scheme-indent-function 1) (put 'let-values 'scheme-indent-function 1) |
Modified genexample.scm from [2597a6cc06] to [4609ee6b65].
︙ | ︙ | |||
15 16 17 18 19 20 21 | ;; ;; 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 genexample)) | | > > | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | ;; ;; 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 genexample)) (use posix regex matchable) (include "db_records.scm") (define genexample:example-logpro #<<EOF ;; You should have at least one expect:required. This ensures that your process ran ;; comment out the line below and replace "put pattern here" with a pattern that will ;; always be seen in your log file if the step runs successfully. ;; |
︙ | ︙ | |||
336 337 338 339 340 341 342 | (if (string-match ".*\\.sh$" script) (begin (with-output-to-file (conc testdir "/" script) (lambda () (print genexample:example-script))) (system (conc "chmod ug+r,a+x " (conc testdir "/" script))))))) steps)))))) | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 | (if (string-match ".*\\.sh$" script) (begin (with-output-to-file (conc testdir "/" script) (lambda () (print genexample:example-script))) (system (conc "chmod ug+r,a+x " (conc testdir "/" script))))))) steps)))))) ;; easier to work backwards than change the upstream code ;; (define (hrs-min-sec->seconds str) (let* ((parts (string-split str)) (res 0)) (for-each (lambda (part) (set! res (+ res (match (string-match "(\\d+)([a-z])" part) ((_ val units)(* (string->number val)(case (string->symbol units) ((s) 1) ((m) 60) ((h) 3600)))) (else 0))))) parts) res)) ;; generate a skeleton Megatest area from a current area with runs ;; ;; specify target, runname etc to use specific runs for the template ;; (define (genexample:extract-skeleton-area dest-path) (let* ((target (args:get-arg "-target")) (runname (args:get-arg "-runname")) (obtuse (make-hash-table)) (obtusef (args:get-arg "-obfuscate")) (letters (string-split-fields "\\S" "abcdefghijklmnopqrstuvwxyz")) (maxletter (- (length letters) 1)) (lastlet 0) (lastnum 1) (obfuscate (lambda (instr) (or (hash-table-ref/default obtuse instr #f) (if obtusef (let* ((letter (list-ref letters lastlet)) (val (conc letter lastnum))) (if (>= lastlet maxletter) (begin (set! lastlet 0) (set! lastnum (+ lastnum 1))) (set! lastlet (+ lastlet 1))) (hash-table-set! obtuse instr val) val) instr))))) (if (not (and target runname)) (debug:print 0 *default-log-port* "WARNING: For best results please specifiy -target and -runname for a good run to use as a template.")) (if (not (and (file-exists? "megatest.config") (file-exists? "megatest.db"))) (begin (debug:print 0 *default-log-port* "ERROR: this command must be run at the top level of a megatest area where runs have been completed") (exit))) ;; first create the dest path and needed subdirectories (if (not (file-exists? dest-path)) (begin (create-directory dest-path) (create-directory (conc dest-path "/tests"))) (if (file-exists? (conc dest-path "/megatest.config")) (begin (debug:print 0 *default-log-port* "ERROR: destination path already has megatest.config, stopping now.") (exit)))) ;; dump the config files from this area to the dest area (if (args:get-arg "-obfuscate") (debug:print 0 *default-log-port* "WARNING: obfuscation is NOT done on megatest.config and runconfigs.config. Please edit those files to remove any sensitive information!")) (system (conc "megatest -show-config > " dest-path "/megatest.config")) (system (conc "megatest -show-runconfig > " dest-path "/runconfigs.config")) ;; create stepsinfo and items refdbs, some stuff has to be done due to refdb not initing area ;; ;; sheet row col value ;; stepsinfo testname itempath stepname steptime ;; miscinfo "itemsinfo" testname itempath "x" ;; (for-each (lambda (rdbname) (if (not (file-exists? (conc dest-path "/" rdbname))) (begin (create-directory (conc dest-path "/" rdbname "/sxml") #t) (with-output-to-file (conc dest-path "/" rdbname "/sheet-names.cfg") (lambda ()(print)))))) '("stepsinfo" "miscinfo")) (let* ((runs (rmt:simple-get-runs (or runname "%") #f #f (or target "%"))) (tests (make-hash-table)) ;; just tests (fullt (make-hash-table)) ;; all test/items (testreg (make-hash-table)) ;; for the testconfigs (stepsrdb (conc dest-path "/stepsinfo")) (miscrdb (conc dest-path "/miscinfo"))) (if (> (length runs) 1) (debug:print-info 0 *default-log-port* "More than one run matches, first found data will be used.")) ;; get all testnames (for-each (lambda (run-id) (let* ((tests-data (rmt:get-tests-for-run run-id "%" '() '() #f #f #f #f #f #f #f #f))) (for-each (lambda (testdat) (let* ((test-id (db:test-get-id testdat)) (testname (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) (tlevel (db:test-get-is-toplevel testdat)) (tfullname (db:test-get-fullname testdat)) ;; now get steps info (test-steps (tests:get-compressed-steps run-id test-id)) (testconfig (tests:get-testconfig testname item-path testreg #f))) (if (not (hash-table-exists? fullt tfullname)) ;; do the work for this test if not previously done (let* ((new-test-dir (conc dest-path "/tests/" (obfuscate testname))) (tconfigf (conc new-test-dir "/testconfig"))) (print "Analyzing and extracting info for " tfullname " as " (obfuscate testname)) (print " toplevel: " (if tlevel "yes" "no")) (hash-table-set! fullt tfullname #t) ;; track that this one has been seen (if (not (directory-exists? new-test-dir)) (create-directory new-test-dir #t)) ;; create the testconfig IIF we are a toplevel or an item AND the testconfig has not been previously created (if (and (or (not tlevel) (not (equal? item-path ""))) (not (file-exists? tconfigf))) (with-output-to-file tconfigf (lambda () ;; first the ezsteps (print "[ezsteps]") (for-each (lambda (teststep) (let* ((step-name (vector-ref teststep 0))) (print (obfuscate step-name) " sleep [refdb lookup #{getenv MT_RUN_AREA_HOME}/stepsinfo " (obfuscate testname) " $MT_ITEMPATH " (obfuscate step-name) "]"))) test-steps) ;; now the requirements section (if testconfig (begin (print "\n[requirements]") (for-each (lambda (entry) (let* ((key (car entry)) (val (cadr entry))) (case (string->symbol key) ((waiton) (print "waiton " (obfuscate val))) (else (print key " " val))))) (configf:get-section testconfig "requirements"))) #;(print "WARNING: No testconfig data for " testname ", " item-path)) (print "\n[items]") (print "THE_ITEM [refdb getrow #{getenv MT_RUN_AREA_HOME}/miscinfo itemsinfo " (obfuscate testname)" | awk '{print $1}']") ))) ;; fill the stepsrdb (for-each (lambda (teststep) (let* ((step-name (vector-ref teststep 0)) (step-duration (hrs-min-sec->seconds (vector-ref teststep 4)))) (system (conc "refdb set " stepsrdb " " (obfuscate testname) " '" (if (equal? item-path "") "no-item-path" (obfuscate item-path)) "' " (obfuscate step-name) " " step-duration)))) test-steps) ;; miscinfo "itemsinfo" testname itempath "x" (if (not (equal? item-path "")) (system (conc "refdb set " miscrdb " itemsinfo " (obfuscate testname) " " (obfuscate item-path) " x"))) )))) tests-data))) (map (lambda (runrec)(simple-run-id runrec)) runs))) )) |
Modified launch.scm from [4cf4021031] to [baaec62bb2].
︙ | ︙ | |||
17 18 19 20 21 22 23 | ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== ;; launch a task - this runs on the originating host, tests themselves ;; ;;====================================================================== | | > > | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== ;; launch a task - this runs on the originating host, tests themselves ;; ;;====================================================================== (use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3 call-with-environment-variables csv) (use typed-records pathname-expand matchable) (import (prefix base64 base64:)) (import (prefix sqlite3 sqlite3:)) (declare (unit launch)) (declare (uses subrun)) (declare (uses common)) (declare (uses configf)) (declare (uses db)) (declare (uses ezsteps)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "megatest-fossil-hash.scm") ;;====================================================================== ;; ezsteps ;;====================================================================== ;; ezsteps were going to be coded as ;; stepname[,predstep1,predstep2 ...] [{VAR1=first,second,third}] command to execute |
︙ | ︙ | |||
722 723 724 725 726 727 728 | ;; new ;; 100% COMPLETED/ (PASS,FAIL,ABORT etc.) ==> COMPLETED / X where X is same as itemized rollup ;; > 3 RUNNING with not test_dead do nothing (run should already be RUNNING/ na ;; > 0 RUNNING and test_dead then send KILLREQ ==> COMPLETED ;; 0 RUNNING ==> this is actually the first condition, should not get here (define (launch:end-of-run-check run-id ) | | | | 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 | ;; new ;; 100% COMPLETED/ (PASS,FAIL,ABORT etc.) ==> COMPLETED / X where X is same as itemized rollup ;; > 3 RUNNING with not test_dead do nothing (run should already be RUNNING/ na ;; > 0 RUNNING and test_dead then send KILLREQ ==> COMPLETED ;; 0 RUNNING ==> this is actually the first condition, should not get here (define (launch:end-of-run-check run-id ) (let* ((not-completed-cnt (rmt:get-not-completed-cnt run-id)) (running-cnt (rmt:get-count-tests-running-for-run-id run-id #f)) ;; fastmode=no (all-test-launched (rmt:get-var (conc "lunch-complete-" run-id))) (current-state (rmt:get-run-state run-id)) (current-status (rmt:get-run-status run-id))) ;;get-vars run-id to query metadata table to check if all completed. if all-test-launched = yes then only not-completed-cnt = 0 means everyting is completed if no entry found in the table do nothing (debug:print 0 *default-log-port* "Running test cnt :" running-cnt) (rmt:set-state-status-and-roll-up-run run-id current-state current-status) (runs:update-junit-test-reporter-xml run-id) |
︙ | ︙ | |||
1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 | (run-time-limit (or (configf:lookup tconfig "requirements" "runtimelim") (configf:lookup *configdat* "setup" "runtimelim"))) ;; FIXME SOMEDAY: not good how this is so obtuse, this hack is to ;; allow running from dashboard. Extract the path ;; from the called megatest and convert dashboard ;; or dboard to megatest (local-megatest (common:find-local-megatest)) (launcher (common:get-launcher *configdat* test-name item-path)) ;; (configf:lookup *configdat* "jobtools" "launcher")) (test-sig (conc (common:get-testsuite-name) ":" test-name ":" item-path)) ;; (item-list->path itemdat))) ;; test-path is the full path including the item-path (work-area #f) (toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all (diskpath #f) (cmdparms #f) (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x)))) (mt-bindir-path #f) (testinfo (rmt:get-test-info-by-id run-id test-id)) (mt_target (string-intersperse (map cadr keyvals) "/")) (debug-param (append (if (args:get-arg "-debug") (list "-debug" (args:get-arg "-debug")) '()) | > > > > > > > > > | > > > | 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 | (run-time-limit (or (configf:lookup tconfig "requirements" "runtimelim") (configf:lookup *configdat* "setup" "runtimelim"))) ;; FIXME SOMEDAY: not good how this is so obtuse, this hack is to ;; allow running from dashboard. Extract the path ;; from the called megatest and convert dashboard ;; or dboard to megatest (local-megatest (common:find-local-megatest)) #;(local-megatest (let* ((lm (car (argv))) (dir (pathname-directory lm)) (exe (pathname-strip-directory lm))) (conc (if dir (conc dir "/") "") (case (string->symbol exe) ((dboard) "../megatest") ((mtest) "../megatest") ((dashboard) "megatest") (else exe))))) (launcher (common:get-launcher *configdat* test-name item-path)) ;; (configf:lookup *configdat* "jobtools" "launcher")) (test-sig (conc (common:get-testsuite-name) ":" test-name ":" item-path)) ;; (item-list->path itemdat))) ;; test-path is the full path including the item-path (work-area #f) (toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all (diskpath #f) (cmdparms #f) (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x)))) (mt-bindir-path #f) (testinfo (rmt:get-test-info-by-id run-id test-id)) (mt_target (string-intersperse (map cadr keyvals) "/")) (debug-param (append (if (args:get-arg "-debug") (list "-debug" (args:get-arg "-debug")) '()) (if (args:get-arg "-logging")(list "-logging") '()) (if (configf:lookup *configdat* "misc" "profilesw") (list (configf:lookup *configdat* "misc" "profilesw")) '())))) ;; (if hosts (set! hosts (string-split hosts))) ;; set the megatest to be called on the remote host (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest")) (set! mt-bindir-path (pathname-directory remote-megatest)) (if launcher (set! launcher (string-split launcher))) ;; set up the run work area for this test (if (and (args:get-arg "-preclean") ;; user has requested to preclean for this run |
︙ | ︙ | |||
1562 1563 1564 1565 1566 1567 1568 | ;; NB// Is this still needed? Should be safe to go back to "exit" now? (process-signal (current-process-id) signal/kill) )) (alist->env-vars miscprevvals) (alist->env-vars testprevvals) (alist->env-vars commonprevvals) launch-results)) | | > | 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 | ;; NB// Is this still needed? Should be safe to go back to "exit" now? (process-signal (current-process-id) signal/kill) )) (alist->env-vars miscprevvals) (alist->env-vars testprevvals) (alist->env-vars commonprevvals) launch-results)) (change-directory *toppath*) (thread-sleep! (configf:lookup-number *configdat* "setup" "inter-test-delay" default: 0.0)))) ;; recover a test where the top controlling mtest may have died ;; (define (launch:recover-test run-id test-id) ;; this function is called on the test run host via ssh ;; ;; 1. look at the process from pid |
︙ | ︙ |
Modified megatest-version.scm from [bdb917f339] to [be0164eb13].
︙ | ︙ | |||
14 15 16 17 18 19 20 | ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; Always use two or four digit decimal ;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. | | | 14 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/>. ;; Always use two or four digit decimal ;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. ;; (declare (unit megatest-version)) (define megatest-version 1.6603) |
Modified megatest.scm from [5271a099fb] to [55e795577f].
︙ | ︙ | |||
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/>. ;; ;; (include "common.scm") | | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | ;; 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/>. ;; ;; (include "common.scm") (include "megatest-version.scm") ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) (declare (uses common)) ;; (declare (uses megatest-version)) (declare (uses margs)) (declare (uses runs)) (declare (uses launch)) (declare (uses server)) (declare (uses client)) (declare (uses tests)) (declare (uses genexample)) |
︙ | ︙ | |||
42 43 44 45 46 47 48 49 50 51 | (declare (uses mt)) (declare (uses api)) (declare (uses tasks)) ;; only used for debugging. (declare (uses env)) (declare (uses diff-report)) (declare (uses commonmod)) (declare (uses adjutant)) ;; (declare (uses ftail)) ;; (import ftail) | > > > | > > > > > > < < | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 | (declare (uses mt)) (declare (uses api)) (declare (uses tasks)) ;; only used for debugging. (declare (uses env)) (declare (uses diff-report)) (declare (uses commonmod)) (declare (uses adjutant)) (declare (uses ulex)) (declare (uses apimod)) (declare (uses rmtmod)) ;; (declare (uses ftail)) ;; (import ftail) (import stml2 mutils commonmod) (import adjutant) (import apimod rmtmod) (import ulex) ;; invoke the imports ;; (declare (uses mtargs.import)) ;; (declare (uses mtconfigf.import)) (declare (uses cookie.import)) (declare (uses stml2.import)) (declare (uses pkts.import)) (declare (uses commonmod.import)) (declare (uses adjutant.import)) (declare (uses ulex.import)) (declare (uses apimod.import)) (declare (uses rmtmod.import)) (define *db* #f) ;; this is only for the repl, do not use in general!!!! (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "megatest-fossil-hash.scm") (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:) readline apropos json http-client directory-utils typed-records http-client srfi-18 extras format) ;; Added for csv stuff - will be removed ;; (use sparse-vectors) (import mutils ducttape-lib stml2) (define *usage-log-file* #f) ;; put path to file for logging usage in this var in the ~/.megatestrc file (define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file ;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file ;; (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc"))) (if (common:file-exists? debugcontrolf) |
︙ | ︙ | |||
181 182 183 184 185 186 187 | :units : name of the units for value, expected_value etc. (optional) -load-test-data : read test specific data for storage in the test_data table from standard in. Each line is comma delimited with four fields category,variable,value,comment Queries -list-runs patt : list runs matching pattern \"patt\", % is the wildcard | < < > > | 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 | :units : name of the units for value, expected_value etc. (optional) -load-test-data : read test specific data for storage in the test_data table from standard in. Each line is comma delimited with four fields category,variable,value,comment Queries -list-runs patt : list runs matching pattern \"patt\", % is the wildcard -show-keys : show the keys used in this megatest setup -test-files targpatt : get the most recent test path/file matching targpatt e.g. %/% or '*.log' returns list sorted by age ascending, see examples below -test-paths : get the test paths matching target, runname, item and test patterns. -list-disks : list the disks available for storing runs -list-targets : list the targets in runconfigs.config -list-db-targets : list the target combinations used in the db -show-config : dump the internal representation of the megatest.config file -show-runconfig : dump the internal representation of the runconfigs.config file -dumpmode MODE : dump in MODE format instead of sexpr, MODE=json,ini,sexp etc. (add -debug 0,9 to see which file contributes each line) -show-cmdinfo : dump the command info for a test (run in test environment) -section sectionName -var varName : for config and runconfig lookup value for sectionName varName -since N : get list of runs changed since time N (Unix seconds) -fields fieldspec : fields to include in json dump; runs:id,runame+tests:testname+steps -sort fieldname : in -list-runs sort tests by this field -testdata-csv [categorypatt/]varpatt : dump testdata for given category Misc -start-dir path : switch to this directory before running megatest -contour cname : add a level of hierarcy to the linktree and run paths -area-tag tagname : add a tag to an area while syncing to pgdb |
︙ | ︙ | |||
242 243 244 245 246 247 248 | -refdb2dat refdb : convert refdb to sexp or to format specified by s-dumpmode formats: perl, ruby, sqlite3, csv (for csv the -o param will substitute %s for the sheet name in generating multiple sheets) -o : output file for refdb2dat (defaults to stdout) -archive cmd : archive runs specified by selectors to one of disks specified in the [archive-disks] section. | | | 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 | -refdb2dat refdb : convert refdb to sexp or to format specified by s-dumpmode formats: perl, ruby, sqlite3, csv (for csv the -o param will substitute %s for the sheet name in generating multiple sheets) -o : output file for refdb2dat (defaults to stdout) -archive cmd : archive runs specified by selectors to one of disks specified in the [archive-disks] section. cmd: keep-html, restore, save, save-remove, get, replicate-db (use -dest to set destination), -include path1,path2... to get or save specific files -generate-html : create a simple html dashboard for browsing your runs -generate-html-structure : create a top level html veiw to list targets/runs and a Run view within each run directory. -list-run-time : list time requered to complete runs. It supports following switches -run-patt <patt> -target-patt <patt> -dumpmode <csv,json,plain-text> -list-test-time : list time requered to complete each test in a run. It following following arguments -runname <patt> -target <patt> -dumpmode <csv,json,plain-text> |
︙ | ︙ | |||
317 318 319 320 321 322 323 324 325 326 327 328 329 330 | "-m" "-rerun" "-days" "-rename-run" "-to" "-dest" ;; values and messages ":category" ":variable" ":value" ":expected" ":tol" ":units" | > > | 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 | "-m" "-rerun" "-days" "-rename-run" "-to" "-dest" "-source" "-time-stamp" ;; values and messages ":category" ":variable" ":value" ":expected" ":tol" ":units" |
︙ | ︙ | |||
388 389 390 391 392 393 394 395 396 397 398 399 400 401 | "-src-runname" "-diff-email" "-sync-to" "-pgsync" "-kill-wait" ;; wait this long before removing test (default is 10 sec) "-diff-html" ) (list "-h" "-help" "--help" "-manual" "-version" "-force" "-xterm" "-showkeys" | > > | 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 | "-src-runname" "-diff-email" "-sync-to" "-pgsync" "-kill-wait" ;; wait this long before removing test (default is 10 sec) "-diff-html" ;; wizards, area capture, setup new ... "-extract-skeleton" ) (list "-h" "-help" "--help" "-manual" "-version" "-force" "-xterm" "-showkeys" |
︙ | ︙ | |||
465 466 467 468 469 470 471 472 473 474 475 476 477 478 | "-logging" "-v" ;; verbose 2, more than normal (normal is 1) "-q" ;; quiet 0, errors/warnings only "-diff-rep" "-syscheck" ) args:arg-hash 0)) ;; Add args that use remargs here ;; (if (and (not (null? remargs)) | > > > > | 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 | "-logging" "-v" ;; verbose 2, more than normal (normal is 1) "-q" ;; quiet 0, errors/warnings only "-diff-rep" "-syscheck" "-obfuscate" ;; junk placeholder ;; "-:p" ) args:arg-hash 0)) ;; Add args that use remargs here ;; (if (and (not (null? remargs)) |
︙ | ︙ | |||
1973 1974 1975 1976 1977 1978 1979 | (print path)) paths)))))) ;;====================================================================== ;; Archive tests ;;====================================================================== ;; Archive tests matching target, runname, and testpatt | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 | (print path)) paths)))))) ;;====================================================================== ;; Archive tests ;;====================================================================== ;; Archive tests matching target, runname, and testpatt (if (equal? (args:get-arg "-archive") "replicacte-db") (begin ;; check if source ;; check if megatest.db exist (launch:setup) (if (not (args:get-arg "-source")) (begin (debug:print-info 1 *default-log-port* "Missing required argument -source <archive path>") (exit 1))) (if (common:file-exists? (conc *toppath* "/megatest.db")) (begin (debug:print-info 1 *default-log-port* "File " (conc *toppath* "/megatest.db") " already exists. Please remove it before trying to replicate db") (exit 1))) (if (and (common:get-db-tmp-area) (> (length (directory (common:get-db-tmp-area) #f)) 0)) (begin (debug:print-info 1 *default-log-port* (common:get-db-tmp-area) " not empty. Please remove it before trying to replicate db") (exit 1))) ;; check if timestamp (let* ((source (args:get-arg "-source")) (src (if (not (equal? (substring source 0 1) "/")) (conc (current-directory) "/" source) source)) (ts (if (args:get-arg "-time-stamp") (args:get-arg "-time-stamp") "latest"))) (if (common:directory-exists? src) (begin (archive:restore-db src ts) (set! *didsomething* #t)) (begin (debug:print-error 1 *default-log-port* "Path " source " not found") (exit 1)))))) ;; else do a general-run-call (if (and (args:get-arg "-archive") (not (equal? (args:get-arg "-archive") "replicacte-db"))) (begin ;; for the archive get we need to preserve the starting dir as part of the target path (if (and (args:get-arg "-dest") (not (equal? (substring (args:get-arg "-dest") 0 1) "/"))) (let ((newpath (conc (current-directory) "/" (args:get-arg "-dest")))) (debug:print-info 1 *default-log-port* "Preserving original path to destination, was " (args:get-arg "-dest") ", now " newpath) (hash-table-set! args:arg-hash "-dest" newpath))) |
︙ | ︙ | |||
2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 | (else (begin (set! *db* dbstruct) (import extras) ;; might not be needed ;; (import csi) (import readline) (import apropos) ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... (if *use-new-readline* (begin (install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines]) (current-input-port (make-readline-port "megatest> "))) (begin | > > | 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 | (else (begin (set! *db* dbstruct) (import extras) ;; might not be needed ;; (import csi) (import readline) (import apropos) (import apimod) (import rmtmod) ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... (if *use-new-readline* (begin (install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines]) (current-input-port (make-readline-port "megatest> "))) (begin |
︙ | ︙ | |||
2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 | (if (args:get-arg "-syscheck") (begin (mutils:syscheck common:raw-get-remote-host-load server:get-best-guess-address read-config) (set! *didsomething* #t))) ;;====================================================================== ;; Exit and clean up ;;====================================================================== (if (not *didsomething*) (debug:print 0 *default-log-port* help) | > > > > > | 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 | (if (args:get-arg "-syscheck") (begin (mutils:syscheck common:raw-get-remote-host-load server:get-best-guess-address read-config) (set! *didsomething* #t))) (if (args:get-arg "-extract-skeleton") (let* ((toppath (launch:setup))) (genexample:extract-skeleton-area (args:get-arg "-extract-skeleton")) (set! *didsomething* #t))) ;;====================================================================== ;; Exit and clean up ;;====================================================================== (if (not *didsomething*) (debug:print 0 *default-log-port* help) |
︙ | ︙ |
Modified mtexec.scm from [63fcb68d27] to [6016ee8684].
︙ | ︙ | |||
24 25 26 27 28 29 30 | (use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras) srfi-19 srfi-18 extras format pkts regex regex-case (prefix dbi dbi:) ) ;; (declare (uses common)) | < | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | (use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras) srfi-19 srfi-18 extras format pkts regex regex-case (prefix dbi dbi:) ) ;; (declare (uses common)) (declare (uses margs)) (declare (uses configf)) ;; (declare (uses rmt)) ;; (use ducttape-lib) (include "megatest-version.scm") (include "megatest-fossil-hash.scm") ;; (require-library stml) (define help (conc " mtutil, part of the Megatest tool suite, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " |
︙ | ︙ |
Modified mtut.scm from [8133cd984a] to [bccf9738b0].
︙ | ︙ | |||
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/>. ;; ;; (include "common.scm") | | < | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | ;; 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/>. ;; ;; (include "common.scm") (include "megatest-version.scm") ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) (use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras) srfi-19 srfi-18 extras format regex regex-case (prefix dbi dbi:) (prefix sqlite3 sqlite3:) nanomsg) (declare (uses common)) (declare (uses margs)) (declare (uses configf)) ;; (declare (uses rmt)) (import ducttape-lib pkts) (include "megatest-fossil-hash.scm") |
︙ | ︙ |
Modified pkts/pkts.scm from [d1cd1cb6f6] to [90f8c93eeb].
︙ | ︙ | |||
619 620 621 622 623 624 625 | ;; schema is list of SQL statements - can be used to extend db with more tables ;; (define (open-queue-db dbpath dbfile #!key (schema '())) (let* ((dbfname (conc dbpath "/" dbfile)) (dbexists (if (file-exists? dbfname) #t (begin (create-directory dbpath #t) #f))) (db (dbi:open 'sqlite3 (list (cons 'dbname dbfname))))) | | | 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 | ;; schema is list of SQL statements - can be used to extend db with more tables ;; (define (open-queue-db dbpath dbfile #!key (schema '())) (let* ((dbfname (conc dbpath "/" dbfile)) (dbexists (if (file-exists? dbfname) #t (begin (create-directory dbpath #t) #f))) (db (dbi:open 'sqlite3 (list (cons 'dbname dbfname))))) ;; (set-busy-handler! (dbi:db-conn db) (busy-timeout 10000)) (if (not dbexists) ;; NOTE: In the archive we allow duplicates and other messiness. (for-each (lambda (stmt) (dbi:exec db stmt)) (cons "CREATE TABLE IF NOT EXISTS pkts (id INTEGER PRIMARY KEY, group_id INTEGER NOT NULL, |
︙ | ︙ |
Added reindent.el version [9e7e328bbc].
> > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | ; Indenting module body code at column 0 (defun scheme-module-indent (state indent-point normal-indent) 0) (put 'module 'scheme-indent-function 'scheme-module-indent) (put 'and-let* 'scheme-indent-function 1) (put 'parameterize 'scheme-indent-function 1) (put 'handle-exceptions 'scheme-indent-function 1) (put 'when 'scheme-indent-function 1) (put 'unless 'scheme-indent-function 1) (put 'match 'scheme-indent-function 1) (put 'let-values 'scheme-indent-function 1) ;; do the work (indent-region (point-min) (point-max) nil) |
Modified rmt.scm from [6209f83b0d] to [8da01de566].
︙ | ︙ | |||
491 492 493 494 495 496 497 498 499 500 501 502 503 504 | (define (rmt:get-run-record-ids target run keynames test-patt) (rmt:send-receive 'get-run-record-ids #f (list target run keynames test-patt))) (define (rmt:get-changed-record-ids since-time) (rmt:send-receive 'get-changed-record-ids #f (list since-time)) ) ;;====================================================================== ;; T E S T M E T A ;;====================================================================== (define (rmt:get-tests-tags) (rmt:send-receive 'get-tests-tags #f '())) | > > > > > > | 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 | (define (rmt:get-run-record-ids target run keynames test-patt) (rmt:send-receive 'get-run-record-ids #f (list target run keynames test-patt))) (define (rmt:get-changed-record-ids since-time) (rmt:send-receive 'get-changed-record-ids #f (list since-time)) ) (define (rmt:drop-all-triggers) (rmt:send-receive 'drop-all-triggers #f '())) (define (rmt:create-all-triggers) (rmt:send-receive 'create-all-triggers #f '())) ;;====================================================================== ;; T E S T M E T A ;;====================================================================== (define (rmt:get-tests-tags) (rmt:send-receive 'get-tests-tags #f '())) |
︙ | ︙ | |||
692 693 694 695 696 697 698 | ;; (define (rmt:get-run-ids-matching keynames target res) ;; (rmt:send-receive #f 'get-run-ids-matching (list keynames target res))) (define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f)) (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-test-name ref-item-path mode itemmaps))) | | | | | | 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 | ;; (define (rmt:get-run-ids-matching keynames target res) ;; (rmt:send-receive #f 'get-run-ids-matching (list keynames target res))) (define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f)) (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-test-name ref-item-path mode itemmaps))) (define (rmt:get-count-tests-running-for-run-id run-id fastmode) (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id fastmode))) (define (rmt:get-not-completed-cnt run-id) (rmt:send-receive 'get-not-completed-cnt run-id (list run-id))) ;; Statistical queries (define (rmt:get-count-tests-running run-id fastmode) (rmt:send-receive 'get-count-tests-running run-id (list run-id fastmode))) (define (rmt:get-count-tests-running-for-testname run-id testname) (rmt:send-receive 'get-count-tests-running-for-testname run-id (list run-id testname))) (define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup) (rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup))) |
︙ | ︙ | |||
789 790 791 792 793 794 795 796 797 798 799 800 801 802 | (define (rmt:set-run-status run-id run-status #!key (msg #f)) (rmt:send-receive 'set-run-status #f (list run-id run-status msg))) (define (rmt:set-run-state-status run-id state status ) (rmt:send-receive 'set-run-state-status #f (list run-id state status))) (define (rmt:update-run-event_time run-id) (rmt:send-receive 'update-run-event_time #f (list run-id))) (define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-runs-update #!key (sort-order "asc")) ;; fields of #f uses default (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit fields last-runs-update sort-order))) | > > | 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 | (define (rmt:set-run-status run-id run-status #!key (msg #f)) (rmt:send-receive 'set-run-status #f (list run-id run-status msg))) (define (rmt:set-run-state-status run-id state status ) (rmt:send-receive 'set-run-state-status #f (list run-id state status))) (define (rmt:update-tesdata-on-repilcate-db old-lt new-lt) (rmt:send-receive 'update-tesdata-on-repilcate-db #f (list old-lt new-lt))) (define (rmt:update-run-event_time run-id) (rmt:send-receive 'update-run-event_time #f (list run-id))) (define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-runs-update #!key (sort-order "asc")) ;; fields of #f uses default (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit fields last-runs-update sort-order))) |
︙ | ︙ | |||
812 813 814 815 816 817 818 819 820 821 822 823 824 825 | (define (rmt:del-var varname) (rmt:send-receive 'del-var #f (list varname))) (define (rmt:set-var varname value) (rmt:send-receive 'set-var #f (list varname value))) ;;====================================================================== ;; M U L T I R U N Q U E R I E S ;;====================================================================== ;; Need to move this to multi-run section and make associated changes (define (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f)) (let ((run-ids (rmt:get-all-run-ids))) | > > > > > > > > > | 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 | (define (rmt:del-var varname) (rmt:send-receive 'del-var #f (list varname))) (define (rmt:set-var varname value) (rmt:send-receive 'set-var #f (list varname value))) (define (rmt:inc-var varname) (rmt:send-receive 'inc-var #f (list varname))) (define (rmt:dec-var varname) (rmt:send-receive 'dec-var #f (list varname))) (define (rmt:add-var varname value) (rmt:send-receive 'add-var #f (list varname value))) ;;====================================================================== ;; M U L T I R U N Q U E R I E S ;;====================================================================== ;; Need to move this to multi-run section and make associated changes (define (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f)) (let ((run-ids (rmt:get-all-run-ids))) |
︙ | ︙ |
Modified rmtmod.scm from [7098937896] to [6b720dfd33].
︙ | ︙ | |||
16 17 18 19 20 21 22 23 24 25 26 27 28 | ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit rmtmod)) (declare (uses commonmod)) (module rmtmod * (import scheme chicken data-structures extras) (import (prefix sqlite3 sqlite3:) posix typed-records srfi-18) | > > > > > > | > < < < | | | > | > > > > > | > > > | | | < > > > > | | | < < < | > > > | | < | > | | | | | > > | > > | > > > | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 | ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit rmtmod)) (declare (uses commonmod)) (declare (uses apimod)) ;; (declare (uses apimod.import)) (declare (uses ulex)) ;; (include "ulex/ulex.scm") (module rmtmod * (import scheme chicken data-structures extras) (import (prefix sqlite3 sqlite3:) posix typed-records srfi-18) (import (prefix commonmod cmod:)) (import apimod) (import (prefix ulex ulex:)) (defstruct alldat (areapath #f) (ulexdat #f) ) ;; return the handle struct for sending queries to a specific database ;; - initializes the connection object if this is the first access ;; - finds the "captain" and asks who to talk to for the given dbfname ;; - establishes the connection to the current dbowner ;; #;(define (rmt:connect alldat dbfname dbtype) (let* ((ulexdat (or (alldat-ulexdat alldat) (rmt:setup-ulex alldat)))) (ulex:connect ulexdat dbfname dbtype))) ;; setup the remote calls #;(define (rmt:setup-ulex alldat) (let* ((udata (ulex:setup))) ;; establish connection to ulex (alldat-ulexdat-set! alldat udata) ;; register all needed procs (ulex:register-handler udata 'ping cmod:get-full-version) ;; override ping with get-full-version (ulex:register-handler udata 'login cmod:get-full-version) ;; force setup of the connection (ulex:register-handler udata 'execute api:execute-requests) udata)) ;; set up a connection to the current owner of the dbfile associated with rid ;; then send the query to that dbfile owner and wait for a response. ;; #;(define (rmt:send-receive alldat cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected (let* (;; (alldat *alldat*) (areapath (alldat-areapath alldat)) (dbtype (if (or (not rid)(< rid 1)) ;; this is the criteria for "main.db" "main" "runs")) (dbfname (if (equal? dbtype "main") "main.db" (conc rid ".db"))) (dbfile (conc areapath "/.db/" dbfname)) (ulexconn (rmt:connect alldat dbfname dbtype)) ;; ulexconn is our new *runremote*, it is a dbowner struct < pdat lastrefresh > (udata (alldat-ulexdat alldat))) (ulex:remote-request udata ulexconn 'immediate dbfile 'execute rid params))) ;; need to call this on the other side ;; (api:execute-requests dbstruct-local (vector (symbol->string cmd) params)))) #;(with-input-from-string (ulex:remote-request udata ulexconn 'immediate dbfile 'execute rid (with-output-to-string (lambda ()(serialize params)))) (lambda ()(deserialize))) ) |
Deleted rpc-transport.scm version [dd887f94ec].
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Modified runs.scm from [70ec443715] to [77a44f327a].
︙ | ︙ | |||
44 45 46 47 48 49 50 | (defstruct runs:dat reglen regfull runname max-concurrent-jobs run-id test-patts required-tests test-registry registry-mutex flags keyvals run-info all-tests-registry can-run-more-tests | | > > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 | (defstruct runs:dat reglen regfull runname max-concurrent-jobs run-id test-patts required-tests test-registry registry-mutex flags keyvals run-info all-tests-registry can-run-more-tests ((can-run-more-tests-count 0) : fixnum) (last-fuel-check 0) ;; time when we last checked fuel (beginning-of-time (current-seconds)) ) (defstruct runs:testdat hed tal reg reruns test-record test-name item-path jobgroup waitons testmode newtal itemmaps prereqs-not-met) ;; look in the $MT_RUN_AREA_HOME/.softlocks directory for key-host-pid.softlock files ;; - remove any that are over 3600 seconds old ;; - if there are any that are younger than 10 seconds ;; * sleep 10 seconds ;; * touch my key-host-pid.softlock file ;; * return ;; - if there are no files younger than 10 seconds ;; * touch my key-host-pid.softlock file ;; * return ;; (define (runs:wait-on-softlock rdat key) (if (not (and *toppath* (file-exists? *toppath*))) ;; don't seem to have toppath yet (debug:print-info 0 *default-log-port* "Can't create softlocks - don't see MTRAH yet.") (let* ((softlocks-dir (conc *toppath* "/.softlocks"))) (if (not (file-exists? softlocks-dir)) (create-directory softlocks-dir #t)) (let* ((my-lock-file (conc softlocks-dir "/" key "-" (get-host-name) "-" (current-process-id) ".softlock")) (lock-files (filter (lambda (x) (not (equal? x my-lock-file))) (glob (conc softlocks-dir "/" key "*.softlock")))) (fresh-locks (any (lambda (x) ;; do we have any locks younger than 10 seconds (let* ((mod-time (file-modification-time x)) (age (- (current-seconds) mod-time))) (cond ((> age 3600) ;; too old to keep, remove it (delete-file* x) #f) ((< age 10) #t) (else #f)))) lock-files))) (if fresh-locks (begin (if (runs:lownoise "runners-softlock-wait" 360) (debug:print-info 0 *default-log-port* "Other runners in flight, giving up some time...")) (thread-sleep! 10)) (begin (if (runs:lownoise "runners-softlock-nowait" 360) (debug:print-info 0 *default-log-port* "No runners in flight, updating softlock")) (let* ((ouf (open-output-file my-lock-file))) (with-output-to-port ouf (lambda ()(print (current-seconds)))) (close-output-port ouf)))) (runs:dat-last-fuel-check-set! rdat (current-seconds)))))) ;; Fourth try, do accounting through time ;; (define (runs:parallel-runners-mgmt rdat) (let ((time-to-check (configf:lookup-number *configdat* "runners" "time-to-check" default: 10)) ;; 28 (time-to-wait (configf:lookup-number *configdat* "runners" "time-to-wait" default: 30)) (now-time (current-seconds))) (if (> (- now-time (runs:dat-last-fuel-check rdat)) time-to-check) ;; time to check (runs:wait-on-softlock rdat "runners")))) ;; To test parallel-runners management start a repl: ;; megatest -repl ;; then run: ;; (runs:test-parallel-runners 60) ;; (define (runs:test-parallel-runners duration #!optional (proc #f)) (let* ((rdat (make-runs:dat)) (rtime 0) (startt (current-seconds)) (endt (+ startt duration))) ((or proc runs:parallel-runners-mgmt) rdat) (let loop () (let* ((wstart (current-seconds))) (if (< wstart endt) (let* ((work-time (random 10))) #;(debug:print-info 0 *default-log-port* "working for " work-time " seconds. Total work: " rtime ", elapsed time: " (- wstart startt)) (thread-sleep! work-time) (set! rtime (+ rtime work-time)) ((or proc runs:parallel-runners-mgmt) rdat) (loop))))) (let* ((done-time (current-seconds))) (debug:print-info 0 *default-log-port* "DONE: rtime=" rtime ", elapsed time=" (- done-time startt) ", ratio=" (/ rtime (- done-time startt)))))) (define (runs:get-mt-env-alist run-id runname target testname itempath) ;;(bb-check-path msg: "runs:set-megatest-env-vars entry") `(("MT_TEST_NAME" . ,testname) ("MT_ITEMPATH" . ,itempath) |
︙ | ︙ | |||
85 86 87 88 89 90 91 | (cons (car key) (cadr key))) (keys:target->keyval (rmt:get-keys) target)) ,@(map (lambda (var) (let ((val (configf:lookup *configdat* "env-override" var))) (cons var val))) (configf:section-vars *configdat* "env-override")))) | < < < < < | 164 165 166 167 168 169 170 171 172 173 174 175 176 177 | (cons (car key) (cadr key))) (keys:target->keyval (rmt:get-keys) target)) ,@(map (lambda (var) (let ((val (configf:lookup *configdat* "env-override" var))) (cons var val))) (configf:section-vars *configdat* "env-override")))) ;; set up needed environment variables given a run-id and optionally a target, itempath etc. ;; (define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)(intarget #f)(testname #f)(itempath #f)) ;;(bb-check-path msg: "runs:set-megatest-env-vars entry") (let* ((target (or intarget (common:args-get-target) |
︙ | ︙ | |||
243 244 245 246 247 248 249 | ;; to cond clauses below where we determine we ;; have too many jobs running rather than each ;; time the and condition above is true (which ;; seems like always)? ((> (runs:dat-can-run-more-tests-count runsdat) 20) ;; original intent was - save cycles, wait a long time (if (runs:lownoise "waiting on tasks" 60)(debug:print-info 2 *default-log-port* "waiting for tasks to complete, sleeping briefly ...")) 10) ;; obviously haven't had any work to do for a while | | | | > | | 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 | ;; to cond clauses below where we determine we ;; have too many jobs running rather than each ;; time the and condition above is true (which ;; seems like always)? ((> (runs:dat-can-run-more-tests-count runsdat) 20) ;; original intent was - save cycles, wait a long time (if (runs:lownoise "waiting on tasks" 60)(debug:print-info 2 *default-log-port* "waiting for tasks to complete, sleeping briefly ...")) 10) ;; obviously haven't had any work to do for a while (else 0))) ;; ;; if have a number for inter-test-delay, use it, else don't delay much, maybe even zero? ;; (configf:lookup-number *configdat* "setup" "inter-test-delay" default: 0.01) ;; ))) (let* ((num-running (rmt:get-count-tests-running run-id #f)) ;; fastmode=no (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)) (job-group-limit (let ((jobg-count (configf:lookup *configdat* "jobgroups" jobgroup))) (if (string? jobg-count) (string->number jobg-count) jobg-count)))) (if (> (+ num-running num-running-in-jobgroup) 0) (runs:inc-can-run-more-tests-count runsdat)) ;; (set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1))) |
︙ | ︙ | |||
1286 1287 1288 1289 1290 1291 1292 | run-info: #f runname: #f target: #f ) ) (define (runs:incremental-print-results run-id) | | | > | > | 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 | run-info: #f runname: #f target: #f ) ) (define (runs:incremental-print-results run-id) (let ((curr-sec (current-seconds)) (last-update (runs:gendat-inc-results-last-update *runs:general-data*))) (if (> (- curr-sec last-update) 5) ;; at least five seconds since last update (let* ((run-dat (or (runs:gendat-run-info *runs:general-data*)(rmt:get-run-info run-id))) (runname (or (runs:gendat-runname *runs:general-data*) (db:get-value-by-header (db:get-rows run-dat) (db:get-header run-dat) "runname"))) (target (or (runs:gendat-target *runs:general-data*)(rmt:get-target run-id))) (testsdat (let ((res (rmt:get-tests-for-run run-id "%" '() '() ;; run-id testpatt states statuses #f #f ;; offset limit #f ;; not-in #f ;; sort-by #f ;; sort-order #f ;; get full data (not 'shortlist) last-update 'dashboard))) (if (list? res) res (begin (debug:print-error 0 *default-log-port* "FAILED TO GET DATA using rmt:get-tests-for-run. Notify developers if you see this. result: " res) '()))))) (runs:gendat-inc-results-last-update-set! *runs:general-data* (- curr-sec 1)) (if (not (runs:gendat-run-info *runs:general-data*)) (runs:gendat-run-info-set! *runs:general-data* run-dat)) (if (not (runs:gendat-runname *runs:general-data*)) (runs:gendat-runname-set! *runs:general-data* runname)) (if (not (runs:gendat-target *runs:general-data*)) (runs:gendat-target-set! *runs:general-data* target)) (for-each |
︙ | ︙ | |||
1344 1345 1346 1347 1348 1349 1350 | state status dtime (seconds->hr-min-sec duration) (conc "lt/" target "/" runname "/" test-name (if (string-null? item-path) "" (conc "/" item-path)))) (hash-table-set! (runs:gendat-inc-results *runs:general-data*) (conc run-id "," test-id) testdat))))) testsdat))) | > > | > > | 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 | state status dtime (seconds->hr-min-sec duration) (conc "lt/" target "/" runname "/" test-name (if (string-null? item-path) "" (conc "/" item-path)))) (hash-table-set! (runs:gendat-inc-results *runs:general-data*) (conc run-id "," test-id) testdat))))) testsdat))) ;; I don't think this should be here? -- Matt #;(runs:gendat-inc-results-last-update-set! *runs:general-data* (- curr-sec 10)) )) ;; every time though the loop increment the test/itempatt val. ;; when the min is > max-allowed and none running then force exit ;; (define *max-tries-hash* (make-hash-table)) ;;====================================================================== |
︙ | ︙ | |||
1472 1473 1474 1475 1476 1477 1478 | )) extras) extras) '()))) (waitons (delete-duplicates (append (tests:testqueue-get-waitons test-record) extra-waits) equal?)) (newtal (append tal (list hed))) (regfull (>= (length reg) reglen)) | | | 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 | )) extras) extras) '()))) (waitons (delete-duplicates (append (tests:testqueue-get-waitons test-record) extra-waits) equal?)) (newtal (append tal (list hed))) (regfull (>= (length reg) reglen)) (num-running (rmt:get-count-tests-running-for-run-id run-id #t)) ;; fastmode=yes (testdat (make-runs:testdat hed: hed tal: tal reg: reg reruns: reruns test-record: test-record test-name: test-name |
︙ | ︙ | |||
1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 | "\n waitons: " waitons "\n num-retries: " num-retries "\n reruns: " reruns "\n regfull: " regfull "\n reglen: " reglen "\n length reg: " (length reg) ) ;; check for hed in waitons => this would be circular, remove it and issue an ;; error (if (member test-name waitons) (begin (debug:print-error 0 *default-log-port* "test " test-name " has listed itself as a waiton, please correct this!") (set! waiton (filter (lambda (x)(not (equal? x hed))) waitons)))) | > > | 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 | "\n waitons: " waitons "\n num-retries: " num-retries "\n reruns: " reruns "\n regfull: " regfull "\n reglen: " reglen "\n length reg: " (length reg) ) (runs:parallel-runners-mgmt runsdat) ;; check for hed in waitons => this would be circular, remove it and issue an ;; error (if (member test-name waitons) (begin (debug:print-error 0 *default-log-port* "test " test-name " has listed itself as a waiton, please correct this!") (set! waiton (filter (lambda (x)(not (equal? x hed))) waitons)))) |
︙ | ︙ | |||
1690 1691 1692 1693 1694 1695 1696 | ))) ;; end loop on sorted test names ;; this is the point where everything is launched and now you can mark the run in metadata table as all launched (rmt:set-var (conc "lunch-complete-" run-id) "yes") ;; now *if* -run-wait we wait for all tests to be done ;; Now wait for any RUNNING tests to complete (if in run-wait mode) (thread-sleep! 10) ;; I think there is a race condition here. Let states/statuses settle | | | | > | | < | > > | | | 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 | ))) ;; end loop on sorted test names ;; this is the point where everything is launched and now you can mark the run in metadata table as all launched (rmt:set-var (conc "lunch-complete-" run-id) "yes") ;; now *if* -run-wait we wait for all tests to be done ;; Now wait for any RUNNING tests to complete (if in run-wait mode) (thread-sleep! 10) ;; I think there is a race condition here. Let states/statuses settle (let wait-loop ((num-running (rmt:get-count-tests-running-for-run-id run-id #t)) ;; fastmode=yes (prev-num-running 0)) ;; (debug:print-info 13 *default-log-port* "num-running=" num-running ", prev-num-running=" prev-num-running) (if (and (or (args:get-arg "-run-wait") (equal? (configf:lookup *configdat* "setup" "run-wait") "yes")) (> num-running 0)) (begin ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes ;; (debug:print 0 *default-log-port* "Got here eh! num-running=" num-running " (> num-running 0) " (> num-running 0)) (if (> (current-seconds)(+ last-time-incomplete 900)) (let ((actual-num-running (rmt:get-count-tests-running-for-run-id run-id #f))) ;; fastmode=no (debug:print-info 0 *default-log-port* "Marking stuck tests as INCOMPLETE while waiting for run " run-id ". Running as pid " (current-process-id) " on " (get-host-name)) (set! last-time-incomplete (current-seconds)) ;; FIXME, this might be causing slow down - use of set! (rmt:find-and-mark-incomplete run-id #f) (debug:print-info 0 *default-log-port* "run-wait specified, waiting on " actual-num-running " tests in RUNNING, REMOTEHOSTSTART or LAUNCHED state at " (time->string (seconds->local-time (current-seconds)))))) (thread-sleep! 5) (wait-loop (rmt:get-count-tests-running-for-run-id run-id #t) ;; fastmode=yes num-running)))) ;; LET* ((test-record ;; we get here on "drop through". All done! ;; this is moved to runs:run-testes since this function is getting called twice to ensure everthing is completed. ;; (debug:print-info 0 *default-log-port* "Calling Post Hook") ;; (runs:run-post-hook run-id) (debug:print-info 1 *default-log-port* "All tests launched"))) |
︙ | ︙ | |||
2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 | ) ))))) )) runs) ;; special case - archive get (if (equal? (args:get-arg "-archive") "get") (archive:bup-get-data "get" #f #f test-records rp-mutex bup-mutex)) ) #t ) (define (runs:remove-test-directory test mode) ;; remove-data-only) (let* ((run-dir (db:test-get-rundir test)) ;; run dir is from the link tree (real-dir (if (common:file-exists? run-dir) | > > > > > | 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 | ) ))))) )) runs) ;; special case - archive get (if (equal? (args:get-arg "-archive") "get") (archive:bup-get-data "get" #f #f test-records rp-mutex bup-mutex)) (if (or (equal? (args:get-arg "-archive") "save") (equal? (args:get-arg "-archive") "save-remove")) (begin (print "db archive started") (archive:megatest-db target runnamepatt) (print "db archived"))) ) #t ) (define (runs:remove-test-directory test mode) ;; remove-data-only) (let* ((run-dir (db:test-get-rundir test)) ;; run dir is from the link tree (real-dir (if (common:file-exists? run-dir) |
︙ | ︙ |
Modified server.scm from [b1a1de6e53] to [3e4e26900f].
︙ | ︙ | |||
123 124 125 126 127 128 129 130 131 132 133 134 | ;; (dot-server-url (server:check-if-running areapath)) (curr-ip (server:get-best-guess-address curr-host)) (curr-pid (current-process-id)) (homehost (common:get-homehost)) ;; configf:lookup *configdat* "server" "homehost" )) (target-host (car homehost)) (testsuite (common:get-testsuite-name)) (logfile (conc areapath "/logs/server.log")) ;; -" curr-pid "-" target-host ".log")) (cmdln (conc (common:get-megatest-exe) " -server " (or target-host "-") (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes") " -daemonize " "") ;; " -log " logfile | > > | > > | 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 | ;; (dot-server-url (server:check-if-running areapath)) (curr-ip (server:get-best-guess-address curr-host)) (curr-pid (current-process-id)) (homehost (common:get-homehost)) ;; configf:lookup *configdat* "server" "homehost" )) (target-host (car homehost)) (testsuite (common:get-testsuite-name)) (logfile (conc areapath "/logs/server.log")) ;; -" curr-pid "-" target-host ".log")) (profile-mode (or (configf:lookup *configdat* "misc" "profilesw") "")) (cmdln (conc (common:get-megatest-exe) " -server " (or target-host "-") (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes") " -daemonize " "") ;; " -log " logfile " -m testsuite:" testsuite " " profile-mode )) ;; (conc " >> " logfile " 2>&1 &"))))) (log-rotate (make-thread common:rotate-logs "server run, rotate logs thread")) (load-limit (configf:lookup-number *configdat* "jobtools" "max-server-start-load" default: 3.0))) ;; we want the remote server to start in *toppath* so push there (push-directory areapath) (debug:print 0 *default-log-port* "INFO: Trying to start server (" cmdln ") ...") (thread-start! log-rotate) |
︙ | ︙ |
Modified tcmt.scm from [679021e6ef] to [6658a745e5].
︙ | ︙ | |||
27 28 29 30 31 32 33 | (use trace) ;; (trace-call-sites #t) (declare (uses margs)) (declare (uses rmt)) (declare (uses common)) | | > | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | (use trace) ;; (trace-call-sites #t) (declare (uses margs)) (declare (uses rmt)) (declare (uses common)) ;; (declare (uses megatest-version)) (include "megatest-version.scm") (include "megatest-fossil-hash.scm") (include "db_records.scm") (define origargs (cdr (argv))) (define remargs (args:get-args (argv) `( "-target" |
︙ | ︙ |
Modified tests.scm from [bf1af44b82] to [586c05ae4d].
︙ | ︙ | |||
270 271 272 273 274 275 276 | (else ;; not waiting on items, waiting on entire waiton test. (let* ((patts (string-split test-patt ",")) (new-patts (if (member waiton-test patts) patts (cons waiton-test patts)))) (string-intersperse (delete-duplicates new-patts) ","))))) | | > > > > > > | | | | | | | > | < < | | 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 | (else ;; not waiting on items, waiting on entire waiton test. (let* ((patts (string-split test-patt ",")) (new-patts (if (member waiton-test patts) patts (cons waiton-test patts)))) (string-intersperse (delete-duplicates new-patts) ","))))) (define *glob-like-match-cache* (make-hash-table)) (define (tests:cache-regexp str-in flag) (let* ((key (conc str-in flag))) (or (hash-table-ref/default *glob-like-match-cache* key #f) (let* ((newrx (regexp str-in flag))) (hash-table-set! *glob-like-match-cache* key newrx) newrx)))) ;; tests:glob-like-match (define (tests:glob-like-match patt str) (let* ((like (substring-index "%" patt)) (notpatt (equal? (substring-index "~" patt) 0)) (newpatt (if notpatt (substring patt 1) patt)) (finpatt (if like (string-substitute (regexp "%") ".*" newpatt #f) (string-substitute (regexp "\\*") ".*" newpatt #f))) (rx (tests:cache-regexp finpatt (if like #t #f))) (res (string-match rx str))) (if notpatt (not res) res))) ;; if itempath is #f then look only at the testname part ;; (define (tests:match patterns testname itempath #!key (required '())) (if (string? patterns) (let ((patts (append (string-split patterns ",") required))) (if (null? patts) ;;; no pattern(s) means no match |
︙ | ︙ |
Modified tree.scm from [ffabd357b5] to [5b84d6f782].
︙ | ︙ | |||
25 26 27 28 29 30 31 | (use sqlite3 srfi-1 posix regex regex-case srfi-69) (import (prefix sqlite3 sqlite3:)) (declare (unit tree)) (declare (uses margs)) (declare (uses launch)) | | > | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | (use sqlite3 srfi-1 posix regex regex-case srfi-69) (import (prefix sqlite3 sqlite3:)) (declare (unit tree)) (declare (uses margs)) (declare (uses launch)) ;; (declare (uses megatest-version)) (declare (uses gutils)) (declare (uses db)) (declare (uses server)) ;; (declare (uses synchash)) (declare (uses dcommon)) (include "megatest-version.scm") (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") ;;====================================================================== ;; T R E E S T U F F ;;====================================================================== |
︙ | ︙ |
Added ulex.scm version [39353b5283].
> > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | ;;====================================================================== ;; Copyright 2019, Matthew Welland. ;; ;; This file is part of Megatest. ;; ;; Megatest is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; Megatest is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit ulex)) (declare (uses pkts)) (include "ulex/ulex.scm") |
Added ulex/ulex.scm version [42b648b50c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 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 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 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 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 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 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 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 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 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 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 | ;; ulex: Distributed sqlite3 db ;;; ;; Copyright (C) 2018 Matt Welland ;; Redistribution and use in source and binary forms, with or without ;; modification, is permitted. ;; ;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS ;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE ;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT ;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE ;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;; DAMAGE. ;;====================================================================== ;; ABOUT: ;; See README in the distribution at https://www.kiatoa.com/fossils/ulex ;; NOTES: ;; Why sql-de-lite and not say, dbi? - performance mostly, then simplicity. ;; ;;====================================================================== (use mailbox) (module ulex * (import scheme posix chicken data-structures ports extras files mailbox) (import srfi-18 pkts matchable regex typed-records srfi-69 srfi-1 srfi-4 regex-case (prefix sqlite3 sqlite3:) foreign tcp6 ;; ulex-netutil hostinfo ) ;; make it a global? Well, it is local to area module (define *captain-pktspec* `((captain (host . h) (port . p) (pid . i) (ipaddr . a) ) #;(data (hostname . h) ;; sender hostname (port . p) ;; sender port (ipaddr . a) ;; sender ip (hostkey . k) ;; sending host key - store info at server under this key (servkey . s) ;; server key - this needs to match at server end or reject the msg (format . f) ;; sb=serialized-base64, t=text, sx=sexpr, j=json (data . d) ;; base64 encoded slln data ))) ;; struct for keeping track of our world (defstruct udat ;; captain info (captain-address #f) (captain-host #f) (captain-port #f) (captain-pid #f) (captain-lease 0) ;; time (unix epoc) seconds when the lease is up (ulex-dir (conc (get-environment-variable "HOME") "/.ulex")) (cpkts-dir (conc (get-environment-variable "HOME") "/.ulex/pkts")) (cpkt-spec *captain-pktspec*) ;; this processes info (my-cpkt-key #f) ;; put Z card here when I create a pkt for myself as captain (my-address #f) (my-hostname #f) (my-port #f) (my-pid (current-process-id)) (my-dbs '()) ;; server and handler thread (serv-listener #f) ;; this processes server info (handler-thread #f) (mboxes (make-hash-table)) ;; key => mbox ;; other servers (peers (make-hash-table)) ;; host-port => peer record (dbowners (make-hash-table)) ;; dbfile => host-port (handlers (make-hash-table)) ;; dbfile => proc ;; (outgoing-conns (make-hash-table)) ;; host:port -> conn (work-queue (make-queue)) ;; most stuff goes here ;; (fast-queue (make-queue)) ;; super quick stuff goes here (e.g. ping) (busy #f) ;; is either of the queues busy, use to switch between queuing tasks or doing immediately ;; app info (appname #f) (dbtypes (make-hash-table)) ;; this should be an alist but hash is easier. dbtype => [ initproc syncproc ] ;; cookies (cnum 0) ;; cookie num ) ;;====================================================================== ;; NEW APPROACH ;;====================================================================== ;; start-server-find-port ;; gotta have a server port ready from the very begining ;; udata - all the connection info, captain, server, ulex db etc. MUST BE PASSED IN ;; dbpath - full path and filename of the db to talk to or a symbol naming the db? ;; callname - the remote call to execute ;; params - parameters to pass to the remote call ;; (define (remote-call udata dbpath dbtype callname . params) (start-server-find-port udata) ;; ensure we have a local server (find-or-setup-captain udata) ;; look at connect, process-request, send, send-receive (let-values (((cookie-key host-port)(get-db-owner udata dbpath dbtype))) (send-receive udata host-port callname cookie-key params))) ;;====================================================================== ;; KEY FUNCTIONS - THESE ARE TOO BE EXPOSED AND USED ;;====================================================================== ;; connection setup and management functions ;; This is the basic setup command. Must always be ;; called before connecting to a db using connect. ;; ;; find or become the captain ;; setup and return a ulex object ;; (define (find-or-setup-captain udata) ;; see if we already have a captain and if the lease is ok (if (and (udat-captain-address udata) (udat-captain-port udata) (< (current-seconds) (udat-captain-lease udata))) udata (let* ((cpkts (get-all-captain-pkts udata)) ;; read captain pkts (captn (get-winning-pkt cpkts))) (if captn (let* ((port (alist-ref 'port captn)) (host (alist-ref 'host captn)) (ipaddr (alist-ref 'ipaddr captn)) (pid (alist-ref 'pid captn)) (Z (alist-ref 'Z captn))) (udat-captain-address-set! udata ipaddr) (udat-captain-host-set! udata host) (udat-captain-port-set! udata port) (udat-captain-pid-set! udata pid) (udat-captain-lease-set! udata (+ (current-seconds) 10)) (let-values (((success pingtime)(ping udata (conc ipaddr ":" port)))) (if success udata (begin (print "Found unreachable captain at " ipaddr ":" port ", removing pkt") (remove-captain-pkt udata captn) (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))))))) ;; connect to a specific dbfile ;; - if already connected - return the dbowner host-port ;; - ask the captain who to talk to for this db ;; - put the entry in the dbowners hash as dbfile => host-port ;; (define (connect udata dbfname dbtype) (or (hash-table-ref/default (udat-dbowners udata) dbfname #f) (let-values (((success dbowner-host-port)(get-db-owner udata dbfname dbtype))) (if success (begin ;; just clobber the record, this is the new data no matter what (hash-table-set! (udat-dbowners udata) dbfname dbowner-host-port) dbowner-host-port) #f)))) ;; returns: success pingtime ;; ;; NOTE: causes the callee to store the info on this host along with the dbs this host currently owns ;; (define (ping udata host-port) (let* ((start (current-milliseconds)) (cookie (make-cookie udata)) (dbs (udat-my-dbs udata)) (msg (string-intersperse dbs " ")) (res (send udata host-port 'ping cookie msg retval: #t)) (delta (- (current-milliseconds) start))) (values (equal? res cookie) delta))) ;; returns: success pingtime ;; ;; NOTE: causes all references to this worker to be wiped out in the ;; callee (ususally the captain) ;; (define (goodbye-ping udata host-port) (let* ((start (current-milliseconds)) (cookie (make-cookie udata)) (dbs (udat-my-dbs udata)) (res (send udata host-port 'goodbye cookie "nomsg" retval: #t)) (delta (- (current-milliseconds) start))) (values (equal? res cookie) delta))) (define (goodbye-captain udata) (let* ((host-port (udat-captain-host-port udata))) (if host-port (goodbye-ping udata host-port) (values #f -1)))) (define (get-db-owner udata dbname dbtype) (let* ((host-port (udat-captain-host-port udata))) (if host-port (let* ((cookie (make-cookie udata)) (msg #f) ;; (conc dbname " " dbtype)) (params `(,dbname ,dbtype)) (res (send udata host-port 'db-owner cookie msg params: params retval: #t))) (match (string-split res) ((retcookie owner-host-port) (values (equal? retcookie cookie) owner-host-port)))) (values #f -1)))) ;; called in ulex-handler to dispatch work, called on the workers side ;; calls (proc params data) ;; returns result with cookie ;; ;; pdat is the info of the caller, used to send the result data ;; prockey is key into udat-handlers hash dereferencing a proc ;; procparam is a first param handed to proc - often to do further derefrencing ;; NOTE: params is intended to be a list of strings, encoding on data ;; is up to the user but data must be a single line ;; (define (process-request udata pdat dbname cookie prockey procparam data) (let* ((dbrec (ulex-open-db udata dbname)) ;; this will be a dbconn record, looks for in udata first (proc (hash-table-ref udata prockey))) (let* ((result (proc dbrec procparam data))) result))) ;; remote-request - send to remote to process in process-request ;; uconn comes from a call to connect and can be used instead of calling connect again ;; uconn is the host-port to call ;; we send dbname to the worker so they know which file to open ;; data must be a string with no newlines, it will be handed to the proc ;; at the remote site unchanged. It is up to the user to encode/decode it's contents ;; ;; rtype: immediate, read-only, normal, low-priority ;; (define (remote-request udata uconn rtype dbname prockey procparam data) (let* ((cookie (make-cookie udata))) (send-receive udata uconn rtype cookie data `(,prockey procparam)))) (define (ulex-open-db udata dbname) #f) ;;====================================================================== ;; Ulex db ;; ;; - track who is captain, lease expire time ;; - track who owns what db, lease ;; ;;====================================================================== ;; ;; (define (ulex-dbfname) (let ((dbdir (conc (get-environment-variable "HOME") "/.ulex"))) (if (not (file-exists? dbdir)) (create-directory dbdir #t)) (conc dbdir "/network.db"))) ;; always goes in ~/.ulex/network.db ;; role is captain, adjutant, node ;; (define (ulexdb-setup) (let* ((dbfname (ulex-dbfname)) (have-db (file-exists? dbfname)) (db (sqlite3:open-database dbfname))) (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) (sqlite3:execute db "PRAGMA synchronous = 0;") (if (not have-db) (sqlite3:with-transaction db (lambda () (for-each (lambda (stmt) (if stmt (sqlite3:execute db stmt))) `("CREATE TABLE IF NOT EXISTS nodes (id INTEGER PRIMARY KEY, role TEXT NOT NULL, host TEXT NOT NULL, port TEXT NOT NULL, ipadr TEXT NOT NULL, pid INTEGER NOT NULL, zcard TEXT NOT NULL, regtime INTEGER DEFAULT (strftime('%s','now')), lease_thru INTEGER DEFAULT (strftime('%s','now')), last_update INTEGER DEFAULT (strftime('%s','now')));" "CREATE TRIGGER IF NOT EXISTS update_nodes_trigger AFTER UPDATE ON nodes FOR EACH ROW BEGIN UPDATE nodes SET last_update=(strftime('%s','now')) WHERE id=old.id; END;" "CREATE TABLE IF NOT EXISTS dbs (id INTEGER PRIMARY KEY, dbname TEXT NOT NULL, dbfile TEXT NOT NULL, dbtype TEXT NOT NULL, host_port TEXT NOT NULL, regtime INTEGER DEFAULT (strftime('%s','now')), lease_thru INTEGER DEFAULT (strftime('%s','now')), last_update INTEGER DEFAULT (strftime('%s','now')));" "CREATE TRIGGER IF NOT EXISTS update_dbs_trigger AFTER UPDATE ON dbs FOR EACH ROW BEGIN UPDATE dbs SET last_update=(strftime('%s','now')) WHERE id=old.id; END;"))))) db)) (define (get-host-port-lease db dbfname) (sqlite3:fold-row (lambda (rem host-port lease-thru) (list host-port lease-thru)) #f db "SELECT host_port,lease_thru FROM dbs WHERE dbfile = ?" dbfname)) (define (register-captain db host ipadr port pid zcard #!key (lease 20)) (let* ((dbfname (ulex-dbfname)) (host-port (conc host ":" port))) (sqlite3:with-transaction db (lambda () (match (get-host-port-lease db dbfname) ((host-port lease-thru) (if (> (current-seconds) lease-thru) (begin (sqlite3:execute db "UPDATE dbs SET host_port=?,lease_thru=? WHERE dbname=?" (conc host ":" port) (+ (current-seconds) lease) dbfname) #t) #f)) (#f (sqlite3:execute db "INSERT INTO dbs (dbname,dbfile,dbtype,host_port,lease_thru) VALUES (?,?,?,?,?)" "captain" dbfname "captain" host-port (+ (current-seconds) lease))) (else (print "ERROR: Unrecognised result from fold-row") (exit 1))))))) ;;====================================================================== ;; network utilities ;;====================================================================== (define (rate-ip ipaddr) (regex-case ipaddr ( "^127\\..*" _ 0 ) ( "^(10\\.0|192\\.168)\\..*" _ 1 ) ( else 2 ) )) ;; Change this to bias for addresses with a reasonable broadcast value? ;; (define (ip-pref-less? a b) (> (rate-ip a) (rate-ip 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?)) (define (get-all-ips) (map ip->string (vector->list (hostinfo-addresses (host-information (current-hostname)))))) (define (udat-my-host-port udata) (if (and (udat-my-address udata)(udat-my-port udata)) (conc (udat-my-address udata) ":" (udat-my-port udata)) #f)) (define (udat-captain-host-port udata) (if (and (udat-captain-address udata)(udat-captain-port udata)) (conc (udat-captain-address udata) ":" (udat-captain-port udata)) #f)) (define (udat-get-peer udata host-port) (hash-table-ref/default (udat-peers udata) host-port #f)) ;; struct for keeping track of others we are talking to (defstruct peer (addr-port #f) (hostname #f) (pid #f) ;; (inp #f) ;; (oup #f) (dbs '()) ;; list of databases this peer is currently handling ) (defstruct work (peer-dat #f) (handlerkey #f) (qrykey #f) (data #f) (start (current-milliseconds))) #;(defstruct dbowner (pdat #f) (last-update (current-seconds))) ;;====================================================================== ;; Captain functions ;;====================================================================== ;; NB// This needs to be started in a thread ;; ;; setup to be a captain ;; - local server MUST be started already ;; - create pkt ;; - start server port handler ;; (define (setup-as-captain udata) (if (create-captain-pkt udata) (let* ((my-addr (udat-my-address udata)) (my-port (udat-my-port udata)) (th (make-thread (lambda () (ulex-handler-loop udata)) "Captain handler"))) (udat-handler-thread-set! udata th) (udat-captain-address-set! udata my-addr) (udat-captain-port-set! udata my-port) (thread-start! th)) (begin (print "ERROR: failed to create captain pkt") #f))) ;; given a pkts dir read ;; (define (get-all-captain-pkts udata) (let* ((pktsdir (let ((d (udat-cpkts-dir udata))) (if (file-exists? d) d (begin (create-directory d #t) d)))) (all-pkt-files (glob (conc pktsdir "/*.pkt"))) (pkt-spec (udat-cpkt-spec udata))) (map (lambda (pkt-file) (read-pkt->alist pkt-file pktspec: pkt-spec)) all-pkt-files))) ;; sort by D then Z, return one, choose the oldest then ;; differentiate if needed using the Z key ;;l (define (get-winning-pkt pkts) (if (null? pkts) #f (car (sort pkts (lambda (a b) (let ((ad (string->number (alist-ref 'D a))) (bd (string->number (alist-ref 'D b)))) (if (eq? a b) (let ((az (alist-ref 'Z a)) (bz (alist-ref 'Z b))) (string>=? az bz)) (> ad bd)))))))) ;; put the host, ip, port and pid into a pkt in ;; the captain pkts dir ;; - assumes user has already fired up a server ;; which will be in the udata struct ;; (define (create-captain-pkt udata) (if (not (udat-serv-listener udata)) (begin (print "ERROR: create-captain-pkt called with out a listener") #f) (let* ((pktdat `((port . ,(udat-my-port udata)) (host . ,(udat-my-hostname udata)) (ipaddr . ,(udat-my-address udata)) (pid . ,(udat-my-pid udata)))) (pktdir (udat-cpkts-dir udata)) (pktspec (udat-cpkt-spec udata)) ) (udat-my-cpkt-key-set! udata (write-alist->pkt pktdir pktdat pktspec: pktspec ptype: 'captain)) (udat-my-cpkt-key udata)))) ;; remove pkt associated with captn (the Z key .pkt) ;; (define (remove-captain-pkt udata captn) (let ((Z (alist-ref 'Z captn)) (cpktdir (udat-cpkts-dir udata))) (delete-file* (conc cpktdir "/" Z ".pkt")))) ;; call all known peers and tell them to delete their info on the captain ;; thus forcing them to re-read pkts and connect to a new captain ;; call this when the captain needs to exit and if an older captain is ;; detected. Due to delays in sending file meta data in NFS multiple ;; captains can be initiated in a "Storm of Captains", book soon to be ;; on Amazon ;; (define (drop-captain udata) (let* ((peers (hash-table-keys (udat-peers udata))) (cookie (make-cookie udata))) (for-each (lambda (host-port) (send udata host-port 'dropcaptain cookie "nomsg" retval: #t)) peers))) ;;====================================================================== ;; server primitives ;;====================================================================== (define (make-cookie udata) (let ((newcnum (+ (udat-cnum udata) 1))) (udat-cnum-set! udata newcnum) (conc (udat-my-address udata) ":" (udat-my-port udata) "-" (udat-my-pid udata) "-" newcnum))) ;; create a tcp listener and return a populated udat struct with ;; my port, address, hostname, pid etc. ;; return #f if fail to find a port to allocate. ;; ;; 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)) (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))))) (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]]) (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)) (define (get-peer-dat udata host-port #!optional (hostname #f)(pid #f)) (let* ((pdat (or (udat-get-peer udata host-port) (handle-exceptions ;; ERROR - MAKE THIS EXCEPTION HANDLER MORE SPECIFIC exn #f (let ((npdat (make-peer addr-port: host-port))) (if hostname (peer-hostname-set! npdat hostname)) (if pid (peer-pid-set! npdat pid)) npdat))))) pdat)) ;; send structured data to recipient ;; ;; NOTE: qrykey is what was called the "cookie" previously ;; ;; retval tells send to expect and wait for return data (one line) and return it or time out ;; this is for ping where we don't want to necessarily have set up our own server yet. ;; (define (send udata host-port handler qrykey data #!key (hostname #f)(pid #f)(params '())(retval #f)) (let* ((my-host-port (udat-my-host-port udata)) (isme (equal? host-port my-host-port)) ;; am I calling ;; myself? (dat (list handler ;; " " my-host-port ;; " " (udat-my-pid udata) ;; " " qrykey params ;;(if (null? params) "" (conc " " ;;(string-intersperse params " "))) ))) ;; (print "send isme is " (if isme "true!" "false!") ", ;; my-host-port: " my-host-port ", host-port: " host-port) (if isme (ulex-handler udata dat data) (handle-exceptions ;; ERROR - MAKE THIS EXCEPTION HANDLER MORE ;; SPECIFIC exn #f (let-values (((inp oup)(tcp-connect host-port))) ;; ;; CONTROL LINE: ;; handlerkey host:port pid qrykey params ... ;; (let ((res (if (and inp oup) (let* () (if my-host-port (begin (write dat oup) (write data oup) ;; send as sexpr ;; (print "Sent dat: " dat " data: " data) (if retval (read inp) #t)) (begin (print "ERROR: send called but no receiver has been setup. Please call setup first!") #f)) ;; NOTE: DO NOT BE TEMPTED TO LOOK AT ANY DATA ON INP HERE! ;; (there is a listener for handling that) ) #f))) ;; #f means failed to connect and send (close-input-port inp) (close-output-port oup) res)))))) ;; send a request to the given host-port and register a mailbox in udata ;; wait for the mailbox data and return it ;; (define (send-receive udata host-port handler qrykey data #!key (hostname #f)(pid #f)(params '())(timeout 20)) (let ((mbox (make-mailbox)) (mbox-time (current-milliseconds)) (mboxes (udat-mboxes udata))) (hash-table-set! mboxes qrykey mbox) (if (send udata host-port handler qrykey data hostname: hostname pid: pid params: params) (let* ((mbox-timeout-secs timeout) (mbox-timeout-result 'MBOX_TIMEOUT) (res (mailbox-receive! mbox mbox-timeout-secs mbox-timeout-result)) (mbox-receive-time (current-milliseconds))) (hash-table-delete! mboxes qrykey) (if (eq? res 'MBOX_TIMEOUT) #f res)) #f))) ;; #f means failed to communicate ;; (define (ulex-handler udata controldat data) (print "controldat: " controldat " data: " data) (match controldat ;; (string-split controldat) ((handlerkey host-port pid qrykey params ...) ;; (print "handlerkey: " handlerkey " host-port: " host-port " pid: " pid " qrykey: " qrykey " params: " params) (case handlerkey ;; (string->symbol handlerkey) ((ack)(print "Got ack!")) ((ping) ;; special case - return result immediately on the same connection (let* ((proc (hash-table-ref/default (udat-handlers udata) 'ping #f)) (val (if proc (proc) "gotping")) (peer (make-peer addr-port: host-port pid: pid)) (dbshash (udat-dbowners udata))) (peer-dbs-set! peer params) ;; params for ping is list of dbs owned by pinger (for-each (lambda (dbfile) (hash-table-set! dbshash dbfile host-port)) ;; WRONG? params) ;; register each db in the dbshash (if (not (hash-table-exists? (udat-peers udata) host-port)) (hash-table-set! (udat-peers udata) host-port peer)) ;; save the details of this caller in peers qrykey)) ;; End of ping ((goodbye) ;; remove all traces of the caller in db ownership etc. (let* ((peer (hash-table-ref/default (udat-peers udata) host-port #f)) (dbs (if peer (peer-dbs peer) '())) (dbshash (udat-dbowners udata))) (for-each (lambda (dbfile)(hash-table-delete! dbshash dbfile)) dbs) (hash-table-delete! (udat-peers udata) host-port) qrykey)) ((dropcaptain) ;; remove all traces of the captain (udat-captain-address-set! udata #f) (udat-captain-host-set! udata #f) (udat-captain-port-set! udata #f) (udat-captain-pid-set! udata #f) qrykey) ((rucaptain) ;; remote is asking if I'm the captain (if (udat-my-cpkt-key udata) "yes" "no")) ((db-owner) ;; given a db name who do I send my queries to ;; look up the file in handlers, if have an entry ping them to be sure ;; they are still alive and then return that host:port. ;; if no handler found or if the ping fails pick from peers the oldest that ;; is managing the fewest dbs (match params ((dbfile dbtype) (let* ((owner-host-port (hash-table-ref/default (udat-dbowners udata) dbfile #f))) (if owner-host-port (conc qrykey " " owner-host-port) (let* ((pdat (or (hash-table-ref/default (udat-peers udata) host-port #f) ;; no owner - caller gets to own it! (make-peer addr-port: host-port pid: pid dbs: `(,dbfile))))) (hash-table-set! (udat-peers udata) host-port pdat) (hash-table-set! (udat-dbowners udata) dbfile host-port) (conc qrykey " " host-port))))) (else (conc qrykey " BADDATA")))) ;; for work items: ;; handler is one of; immediate, read-only, read-write, high-priority ((immediate read-only normal low-priority) ;; do this work immediately ;; host-port (caller), pid (caller), qrykey (cookie), params <= all from first line ;; data => a single line encoded however you want, or should I build json into it? (print "handlerkey=" handlerkey) (let* ((pdat (get-peer-dat udata host-port))) (match params ;; dbfile prockey procparam ((dbfile prockey procparam) (case handlerkey ((immediate read-only) (process-request udata pdat dbfile qrykey prockey procparam data)) ((normal low-priority) ;; split off later and add logic to support low priority (add-to-work-queue udata pdat dbfile qrykey prockey procparam data)) (else #f))) (else (print "INFO: params=" params " handlerkey=" handlerkey " controldat=" controldat) #f)))) (else ;; (add-to-work-queue udata (get-peer-dat udata host-port) handlerkey qrykey data) #f))) (else (print "BAD DATA? controldat=" controldat " data=" data) #f)));; handles the incoming messages and dispatches to queues ;; (define (ulex-handler-loop udata) (let* ((serv-listener (udat-serv-listener udata))) ;; data comes as two lines ;; handlerkey resp-addr:resp-port hostname pid qrykey [dbpath/dbfile.db] ;; data (let loop ((state 'start)) (let-values (((inp oup)(tcp-accept serv-listener))) (let* ((controldat (read inp)) (data (read inp)) (resp (ulex-handler udata controldat data))) (if resp (write resp oup)) (close-input-port inp) (close-output-port oup)) (loop state))))) ;; add a proc to the handler list, these are done symetrically (i.e. in all instances) ;; so that the proc can be dereferenced remotely ;; (define (register-handler udata key proc) (hash-table-set! (udat-handlers udata) key proc)) ;;====================================================================== ;; work queues ;;====================================================================== (define (add-to-work-queue udata peer-dat handlerkey qrykey data) (let ((wdat (make-work peer-dat: peer-dat handlerkey: handlerkey qrykey: qrykey data: data))) (if (udat-busy udata) (queue-add! (udat-work-queue udata) wdat) (process-work udata wdat)) ;; passing in wdat tells process-work to first process the passed in wdat )) (define (do-work udata wdat) #f) (define (process-work udata #!optional wdat) (if wdat (do-work udata wdat)) ;; process wdat (let ((wqueue (udat-work-queue udata))) (if (not (queue-empty? wqueue)) (let loop ((wd (queue-remove! wqueue))) (do-work udata wd) (if (not (queue-empty? wqueue)) (loop (queue-remove! wqueue))))))) ;;====================================================================== ;; Generic db handling ;; setup a inmem db instance ;; open connection to on-disk db ;; sync on-disk db to inmem ;; get lock in on-disk db for dbowner of this db ;; put sync-proc, init-proc, on-disk handle, inmem handle in dbconn stuct ;; return the stuct ;;====================================================================== (defstruct dbconn (fname #f) (inmem #f) (conn #f) (sync #f) ;; sync proc (init #f) ;; init proc (lastsync (current-seconds)) ) (defstruct dbinfo (initproc #f) (syncproc #f)) ;; open inmem and disk database ;; init with initproc ;; return db struct ;; ;; appname; megatest, ulex or something else. ;; (define (setup-db-connection udata fname-in appname dbtype) (let* ((is-ulex (eq? appname 'ulex)) (dbinf (if is-ulex ;; ulex is a built-in special case (make-dbinfo initproc: ulexdb-init syncproc: ulexdb-sync) (hash-table-ref/default (udat-dbtypes udata) dbtype #f))) (initproc (dbinfo-initproc dbinf)) (syncproc (dbinfo-syncproc dbinf)) (fname (if is-ulex (conc (udat-ulex-dir udata) "/ulex.db") fname-in)) (inmem-db (open-and-initdb udata #f 'inmem (dbinfo-initproc dbinf))) (disk-db (open-and-initdb udata fname 'disk (dbinfo-initproc dbinf)))) (make-dbconn inmem: inmem-db conn: disk-db sync: syncproc init: initproc))) ;; dest='inmem or 'disk ;; (define (open-and-initdb udata filename dest init-proc) (let* ((inmem (eq? dest 'inmem)) (dbfile (if inmem ":INMEM:" filename)) (dbexists (if inmem #t (file-exists? dbfile))) (db (sqlite3:open-database dbfile))) (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) (if (not dbexists) (init-proc db)) db)) ;;====================================================================== ;; Previous Ulex db stuff ;;====================================================================== (define (ulexdb-init db inmem) (sqlite3:with-transaction db (lambda () (for-each (lambda (stmt) (if stmt (sqlite3:execute db stmt))) `("CREATE TABLE IF NOT EXISTS processes (id INTEGER PRIMARY KEY, host TEXT NOT NULL, ipadr TEXT NOT NULL, port INTEGER NOT NULL, pid INTEGER NOT NULL, regtime INTEGER DEFAULT (strftime('%s','now')), last_update INTEGER DEFAULT (strftime('%s','now')));" (if inmem "CREATE TRIGGER IF NOT EXISTS update_proces_trigger AFTER UPDATE ON processes FOR EACH ROW BEGIN UPDATE processes SET last_update=(strftime('%s','now')) WHERE id=old.id; END;" #f)))))) ;; open databases, do initial sync (define (ulexdb-sync dbconndat udata) #f) ) ;; END OF ULEX ;;; ;;====================================================================== ;;; ;; D E B U G H E L P E R S ;;; ;;====================================================================== ;;; ;;; (define (dbg> . args) ;;; (with-output-to-port (current-error-port) ;;; (lambda () ;;; (apply print "dbg> " args)))) ;;; ;;; (define (debug-pp . args) ;;; (if (get-environment-variable "ULEX_DEBUG") ;;; (with-output-to-port (current-error-port) ;;; (lambda () ;;; (apply pp args))))) ;;; ;;; (define *default-debug-port* (current-error-port)) ;;; ;;; (define (sdbg> fn stage-name stage-start stage-end start-time . message) ;;; (if (get-environment-variable "ULEX_DEBUG") ;;; (with-output-to-port *default-debug-port* ;;; (lambda () ;;; (apply print "ulex:" fn " " stage-name " took " (- (if stage-end stage-end (current-milliseconds)) stage-start) " ms. " ;;; (if start-time ;;; (conc "total time " (- (current-milliseconds) start-time) ;;; " ms.") ;;; "") ;;; message ;;; ))))) ;;====================================================================== ;; M A C R O S ;;====================================================================== ;; iup callbacks are not dumping the stack, this is a work-around ;; ;; Some of these routines use: ;; ;; http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html ;; ;; Syntax for defining macros in a simple style similar to function definiton, ;; when there is a single pattern for the argument list and there are no keywords. ;; ;; (define-simple-syntax (name arg ...) body ...) ;; ;; ;; (define-syntax define-simple-syntax ;; (syntax-rules () ;; ((_ (name arg ...) body ...) ;; (define-syntax name (syntax-rules () ((name arg ...) (begin body ...))))))) ;; ;; (define-simple-syntax (catch-and-dump proc procname) ;; (handle-exceptions ;; exn ;; (begin ;; (print-call-chain (current-error-port)) ;; (with-output-to-port (current-error-port) ;; (lambda () ;; (print ((condition-property-accessor 'exn 'message) exn)) ;; (print "Callback error in " procname) ;; (print "Full condition info:\n" (condition->list exn))))) ;; (proc))) ;; ;; ;;====================================================================== ;; R E C O R D S ;;====================================================================== ;;; ;; information about me as a server ;;; ;; ;;; (defstruct area ;;; ;; about this area ;;; (useportlogger #f) ;;; (lowport 32768) ;;; (server-type 'auto) ;; auto=create up to five servers/pkts, main=create pkts, passive=no pkt (unless there are no pkts at all) ;;; (conn #f) ;;; (port #f) ;;; (myaddr (get-my-best-address)) ;;; pktid ;; get pkt from hosts table if needed ;;; pktfile ;;; pktsdir ;;; dbdir ;;; (dbhandles (make-hash-table)) ;; fname => list-of-dbh, NOTE: Should really never need more than one? ;;; (mutex (make-mutex)) ;;; (rtable (make-hash-table)) ;; registration table of available actions ;;; (dbs (make-hash-table)) ;; filename => random number, used for choosing what dbs I serve ;;; ;; about other servers ;;; (hosts (make-hash-table)) ;; key => hostdat ;;; (hoststats (make-hash-table)) ;; key => alist of fname => ( qcount . qtime ) ;;; (reqs (make-hash-table)) ;; uri => queue ;;; ;; work queues ;;; (wqueues (make-hash-table)) ;; fname => qdat ;;; (stats (make-hash-table)) ;; fname => totalqueries ;;; (last-srvup (current-seconds)) ;; last time we updated the known servers ;;; (cookie2mbox (make-hash-table)) ;; map cookie for outstanding request to mailbox of awaiting call ;;; (ready #f) ;;; (health (make-hash-table)) ;; ipaddr:port => num failed pings since last good ping ;;; ) ;;; ;;; ;; host stats ;;; ;; ;;; (defstruct hostdat ;;; (pkt #f) ;;; (dbload (make-hash-table)) ;; "dbfile.db" => queries/min ;;; (hostload #f) ;; normalized load ( 5min load / numcpus ) ;;; ) ;;; ;;; ;; dbdat ;;; ;; ;;; (defstruct dbdat ;;; (dbh #f) ;;; (fname #f) ;;; (write-access #f) ;;; (sths (make-hash-table)) ;; hash mapping query strings to handles ;;; ) ;;; ;;; ;; qdat ;;; ;; ;;; (defstruct qdat ;;; (writeq (make-queue)) ;;; (readq (make-queue)) ;;; (rwq (make-queue)) ;;; (logq (make-queue)) ;; do we need a queue for logging? yes, if we use sqlite3 db for logging ;;; (osshort (make-queue)) ;;; (oslong (make-queue)) ;;; (misc (make-queue)) ;; used for things like ping-full ;;; ) ;;; ;;; ;; calldat ;;; ;; ;;; (defstruct calldat ;;; (ctype 'dbwrite) ;;; (obj #f) ;; this would normally be an SQL statement e.g. SELECT, INSERT etc. ;;; (rtime (current-milliseconds))) ;;; ;;; ;; make it a global? Well, it is local to area module ;;; ;;; (define *pktspec* ;;; `((server (hostname . h) ;;; (port . p) ;;; (pid . i) ;;; (ipaddr . a) ;;; ) ;;; (data (hostname . h) ;; sender hostname ;;; (port . p) ;; sender port ;;; (ipaddr . a) ;; sender ip ;;; (hostkey . k) ;; sending host key - store info at server under this key ;;; (servkey . s) ;; server key - this needs to match at server end or reject the msg ;;; (format . f) ;; sb=serialized-base64, t=text, sx=sexpr, j=json ;;; (data . d) ;; base64 encoded slln data ;;; ))) ;;; ;;; ;; work item ;;; ;; ;;; (defstruct witem ;;; (rhost #f) ;; return host ;;; (ripaddr #f) ;; return ipaddr ;;; (rport #f) ;; return port ;;; (servkey #f) ;; the packet representing the client of this workitem, used by final send-message ;;; (rdat #f) ;; the request - usually an sql query, type is rdat ;;; (action #f) ;; the action: immediate, dbwrite, dbread,oslong, osshort ;;; (cookie #f) ;; cookie id for response ;;; (data #f) ;; the data payload, i.e. parameters ;;; (result #f) ;; the result from processing the data ;;; (caller #f)) ;; the calling peer according to rpc itself ;;; ;;; (define (trim-pktid pktid) ;;; (if (string? pktid) ;;; (substring pktid 0 4) ;;; "nopkt")) ;;; ;;; (define (any->number num) ;;; (cond ;;; ((number? num) num) ;;; ((string? num) (string->number num)) ;;; (else num))) ;;; ;;; (use trace) ;;; (trace-call-sites #t) ;;; ;;; ;;====================================================================== ;;; ;; D A T A B A S E H A N D L I N G ;;; ;;====================================================================== ;;; ;;; ;; look in dbhandles for a db, return it, else return #f ;;; ;; ;;; (define (get-dbh acfg fname) ;;; (let ((dbh-lst (hash-table-ref/default (area-dbhandles acfg) fname '()))) ;;; (if (null? dbh-lst) ;;; (begin ;;; ;; (print "opening db for " fname) ;;; (open-db acfg fname)) ;; Note that the handles get put back in the queue in the save-dbh calls ;;; (let ((rem-lst (cdr dbh-lst))) ;;; ;; (print "re-using saved connection for " fname) ;;; (hash-table-set! (area-dbhandles acfg) fname rem-lst) ;;; (car dbh-lst))))) ;;; ;;; (define (save-dbh acfg fname dbdat) ;;; ;; (print "saving dbh for " fname) ;;; (hash-table-set! (area-dbhandles acfg) fname (cons dbdat (hash-table-ref/default (area-dbhandles acfg) fname '())))) ;;; ;;; ;; open the database, if never before opened init it. put the handle in the ;;; ;; open db's hash table ;;; ;; returns: the dbdat ;;; ;; ;;; (define (open-db acfg fname) ;;; (let* ((fullname (conc (area-dbdir acfg) "/" fname)) ;;; (exists (file-exists? fullname)) ;;; (write-access (if exists ;;; (file-write-access? fullname) ;;; (file-write-access? (area-dbdir acfg)))) ;;; (db (sqlite3:open-database fullname)) ;;; (handler (sqlite3:make-busy-timeout 136000)) ;;; ) ;;; (sqlite3:set-busy-handler! db handler) ;;; (sqlite3:execute db "PRAGMA synchronous = 0;") ;;; (if (not exists) ;; need to init the db ;;; (if write-access ;;; (let ((isql (get-rsql acfg 'dbinitsql))) ;; get the init sql statements ;;; ;; (sqlite3:with-transaction ;;; ;; db ;;; ;; (lambda () ;;; (if isql ;;; (for-each ;;; (lambda (sql) ;;; (sqlite3:execute db sql)) ;;; isql))) ;;; (print "ERROR: no write access to " (area-dbdir acfg)))) ;;; (make-dbdat dbh: db fname: fname write-access: write-access))) ;;; ;;; ;; This is a low-level command to retrieve or to prepare, save and return a prepared statment ;;; ;; you must extract the db handle ;;; ;; ;;; (define (get-sth db cache stmt) ;;; (if (hash-table-exists? cache stmt) ;;; (begin ;;; ;; (print "Reusing cached stmt for " stmt) ;;; (hash-table-ref/default cache stmt #f)) ;;; (let ((sth (sqlite3:prepare db stmt))) ;;; (hash-table-set! cache stmt sth) ;;; ;; (print "prepared stmt for " stmt) ;;; sth))) ;;; ;;; ;; a little more expensive but does all the tedious deferencing - only use if you don't already ;;; ;; have dbdat and db sitting around ;;; ;; ;;; (define (full-get-sth acfg fname stmt) ;;; (let* ((dbdat (get-dbh acfg fname)) ;;; (db (dbdat-dbh dbdat)) ;;; (sths (dbdat-sths dbdat))) ;;; (get-sth db sths stmt))) ;;; ;;; ;; write to a db ;;; ;; acfg: area data ;;; ;; rdat: request data ;;; ;; hdat: (host . port) ;;; ;; ;;; ;; (define (dbwrite acfg rdat hdat data-in) ;;; ;; (let* ((dbname (car data-in)) ;;; ;; (dbdat (get-dbh acfg dbname)) ;;; ;; (db (dbdat-dbh dbdat)) ;;; ;; (sths (dbdat-sths dbdat)) ;;; ;; (stmt (calldat-obj rdat)) ;;; ;; (sth (get-sth db sths stmt)) ;;; ;; (data (cdr data-in))) ;;; ;; (print "dbname: " dbname " acfg: " acfg " rdat: " (calldat->alist rdat) " hdat: " hdat " data: " data) ;;; ;; (print "dbdat: " (dbdat->alist dbdat)) ;;; ;; (apply sqlite3:execute sth data) ;;; ;; (save-dbh acfg dbname dbdat) ;;; ;; #t ;;; ;; )) ;;; ;;; (define (finalize-all-db-handles acfg) ;;; (let* ((dbhandles (area-dbhandles acfg)) ;; dbhandles is hash of fname ==> dbdat ;;; (num 0)) ;;; (for-each ;;; (lambda (area-name) ;;; (print "Closing handles for " area-name) ;;; (let ((dbdats (hash-table-ref/default dbhandles area-name '()))) ;;; (for-each ;;; (lambda (dbdat) ;;; ;; first close all statement handles ;;; (for-each ;;; (lambda (sth) ;;; (sqlite3:finalize! sth) ;;; (set! num (+ num 1))) ;;; (hash-table-values (dbdat-sths dbdat))) ;;; ;; now close the dbh ;;; (set! num (+ num 1)) ;;; (sqlite3:finalize! (dbdat-dbh dbdat))) ;;; dbdats))) ;;; (hash-table-keys dbhandles)) ;;; (print "FINALIZED " num " dbhandles"))) ;;; ;;; ;;====================================================================== ;;; ;; W O R K Q U E U E H A N D L I N G ;;; ;;====================================================================== ;;; ;;; (define (register-db-as-mine acfg dbname) ;;; (let ((ht (area-dbs acfg))) ;;; (if (not (hash-table-ref/default ht dbname #f)) ;;; (hash-table-set! ht dbname (random 10000))))) ;;; ;;; (define (work-queue-add acfg fname witem) ;;; (let* ((work-queue-start (current-milliseconds)) ;;; (action (witem-action witem)) ;; NB the action is the index into the rdat actions ;;; (qdat (or (hash-table-ref/default (area-wqueues acfg) fname #f) ;;; (let ((newqdat (make-qdat))) ;;; (hash-table-set! (area-wqueues acfg) fname newqdat) ;;; newqdat))) ;;; (rdat (hash-table-ref/default (area-rtable acfg) action #f))) ;;; (if rdat ;;; (queue-add! ;;; (case (calldat-ctype rdat) ;;; ((dbwrite) (register-db-as-mine acfg fname)(qdat-writeq qdat)) ;;; ((dbread) (register-db-as-mine acfg fname)(qdat-readq qdat)) ;;; ((dbrw) (register-db-as-mine acfg fname)(qdat-rwq qdat)) ;;; ((oslong) (qdat-oslong qdat)) ;;; ((osshort) (qdat-osshort qdat)) ;;; ((full-ping) (qdat-misc qdat)) ;;; (else ;;; (print "ERROR: no queue for " action ". Adding to dbwrite queue.") ;;; (qdat-writeq qdat))) ;;; witem) ;;; (case action ;;; ((full-ping)(qdat-misc qdat)) ;;; (else ;;; (print "ERROR: No action " action " was registered")))) ;;; (sdbg> "work-queue-add" "queue-add" work-queue-start #f #f) ;;; #t)) ;; for now, simply return #t to indicate request got to the queue ;;; ;;; (define (doqueue acfg q fname dbdat dbh) ;;; ;; (print "doqueue: " fname) ;;; (let* ((start-time (current-milliseconds)) ;;; (qlen (queue-length q))) ;;; (if (> qlen 1) ;;; (print "Processing queue of length " qlen)) ;;; (let loop ((count 0) ;;; (responses '())) ;;; (let ((delta (- (current-milliseconds) start-time))) ;;; (if (or (queue-empty? q) ;;; (> delta 400)) ;; stop working on this queue after 400ms have passed ;;; (list count delta responses) ;; return count, delta and responses list ;;; (let* ((witem (queue-remove! q)) ;;; (action (witem-action witem)) ;;; (rdat (witem-rdat witem)) ;;; (stmt (calldat-obj rdat)) ;;; (sth (full-get-sth acfg fname stmt)) ;;; (ctype (calldat-ctype rdat)) ;;; (data (witem-data witem)) ;;; (cookie (witem-cookie witem))) ;;; ;; do the processing and save the result in witem-result ;;; (witem-result-set! ;;; witem ;;; (case ctype ;; action ;;; ((noblockwrite) ;; blind write, no ack of success returned ;;; (apply sqlite3:execute sth data) ;;; (sqlite3:last-insert-rowid dbh)) ;;; ((dbwrite) ;; blocking write ;;; (apply sqlite3:execute sth data) ;;; #t) ;;; ((dbread) ;; TODO: consider breaking this up and shipping in pieces for large query ;;; (apply sqlite3:map-row (lambda x x) sth data)) ;;; ((full-ping) 'full-ping) ;;; (else (print "Not ready for action " action) #f))) ;;; (loop (add1 count) ;;; (if cookie ;;; (cons witem responses) ;;; responses)))))))) ;;; ;;; ;; do up to 400ms of processing on each queue ;;; ;; - the work-queue-processor will allow the max 1200ms of work to complete but it will flag as overloaded ;;; ;; ;;; (define (process-db-queries acfg fname) ;;; (if (hash-table-exists? (area-wqueues acfg) fname) ;;; (let* ((process-db-queries-start-time (current-milliseconds)) ;;; (qdat (hash-table-ref/default (area-wqueues acfg) fname #f)) ;;; (queue-sym->queue (lambda (queue-sym) ;;; (case queue-sym ;; lookup the queue from qdat given a name (symbol) ;;; ((wqueue) (qdat-writeq qdat)) ;;; ((rqueue) (qdat-readq qdat)) ;;; ((rwqueue) (qdat-rwq qdat)) ;;; ((misc) (qdat-misc qdat)) ;;; (else #f)))) ;;; (dbdat (get-dbh acfg fname)) ;;; (dbh (if (dbdat? dbdat)(dbdat-dbh dbdat) #f)) ;;; (nowtime (current-seconds))) ;;; ;; handle the queues that require a transaction ;;; ;; ;;; (map ;; ;;; (lambda (queue-sym) ;;; ;; (print "processing queue " queue-sym) ;;; (let* ((queue (queue-sym->queue queue-sym))) ;;; (if (not (queue-empty? queue)) ;;; (let ((responses ;;; (sqlite3:with-transaction ;; todo - catch exceptions... ;;; dbh ;;; (lambda () ;;; (let* ((res (doqueue acfg queue fname dbdat dbh))) ;; this does the work! ;;; ;; (print "res=" res) ;;; (match res ;;; ((count delta responses) ;;; (update-stats acfg fname queue-sym delta count) ;;; (sdbg> "process-db-queries" "sqlite3-transaction" process-db-queries-start-time #f #f) ;;; responses) ;; return responses ;;; (else ;;; (print "ERROR: bad return data from doqueue " res))) ;;; ))))) ;;; ;; having completed the transaction, send the responses. ;;; ;; (print "INFO: sending " (length responses) " responses.") ;;; (let loop ((responses-left responses)) ;;; (cond ;;; ((null? responses-left) #t) ;;; (else ;;; (let* ((witem (car responses-left)) ;;; (response (cdr responses-left))) ;;; (call-deliver-response acfg (witem-ripaddr witem)(witem-rport witem) ;;; (witem-cookie witem)(witem-result witem))) ;;; (loop (cdr responses-left)))))) ;;; ))) ;;; '(wqueue rwqueue rqueue)) ;;; ;;; ;; handle misc queue ;;; ;; ;;; ;; (print "processing misc queue") ;;; (let ((queue (queue-sym->queue 'misc))) ;;; (doqueue acfg queue fname dbdat dbh)) ;;; ;; .... ;;; (save-dbh acfg fname dbdat) ;;; #t ;; just to let the tests know we got here ;;; ) ;;; #f ;; nothing processed ;;; )) ;;; ;;; ;; run all queues in parallel per db but sequentially per queue for that db. ;;; ;; - process the queues every 500 or so ms ;;; ;; - allow for long running queries to continue but all other activities for that ;;; ;; db will be blocked. ;;; ;; ;;; (define (work-queue-processor acfg) ;;; (let* ((threads (make-hash-table))) ;; fname => thread ;;; (let loop ((fnames (hash-table-keys (area-wqueues acfg))) ;;; (target-time (+ (current-milliseconds) 50))) ;;; ;;(if (not (null? fnames))(print "Processing for these databases: " fnames)) ;;; (for-each ;;; (lambda (fname) ;;; ;; (print "processing for " fname) ;;; ;;(process-db-queries acfg fname)) ;;; (let ((th (hash-table-ref/default threads fname #f))) ;;; (if (and th (not (member (thread-state th) '(dead terminated)))) ;;; (begin ;;; (print "WARNING: worker thread for " fname " is taking a long time.") ;;; (print "Thread is in state " (thread-state th))) ;;; (let ((th1 (make-thread (lambda () ;;; ;; (catch-and-dump ;;; ;; (lambda () ;;; ;; (print "Process queries for " fname) ;;; (let ((start-time (current-milliseconds))) ;;; (process-db-queries acfg fname) ;;; ;; (thread-sleep! 0.01) ;; need the thread to take at least some time ;;; (hash-table-delete! threads fname)) ;; no mutexes? ;;; fname) ;;; "th1"))) ;; )) ;;; (hash-table-set! threads fname th1) ;;; (thread-start! th1))))) ;;; fnames) ;;; ;; (thread-sleep! 0.1) ;; give the threads some time to process requests ;;; ;; burn time until 400ms is up ;;; (let ((now-time (current-milliseconds))) ;;; (if (< now-time target-time) ;;; (let ((delta (- target-time now-time))) ;;; (thread-sleep! (/ delta 1000))))) ;;; (loop (hash-table-keys (area-wqueues acfg)) ;;; (+ (current-milliseconds) 50))))) ;;; ;;; ;;====================================================================== ;;; ;; S T A T S G A T H E R I N G ;;; ;;====================================================================== ;;; ;;; (defstruct stat ;;; (qcount-avg 0) ;; coarse running average ;;; (qtime-avg 0) ;; coarse running average ;;; (qcount 0) ;; total ;;; (qtime 0) ;; total ;;; (last-qcount 0) ;; last ;;; (last-qtime 0) ;; last ;;; (dbs '()) ;; list of db files handled by this node ;;; (when 0)) ;; when the last query happened - seconds ;;; ;;; ;;; (define (update-stats acfg fname bucket duration numqueries) ;;; (let* ((key fname) ;; for now do not use bucket. Was: (conc fname "-" bucket)) ;; lazy but good enough ;;; (stats (or (hash-table-ref/default (area-stats acfg) key #f) ;;; (let ((newstats (make-stat))) ;;; (hash-table-set! (area-stats acfg) key newstats) ;;; newstats)))) ;;; ;; when the last query happended (used to remove the fname from the active list) ;;; (stat-when-set! stats (current-seconds)) ;;; ;; last values ;;; (stat-last-qcount-set! stats numqueries) ;;; (stat-last-qtime-set! stats duration) ;;; ;; total over process lifetime ;;; (stat-qcount-set! stats (+ (stat-qcount stats) numqueries)) ;;; (stat-qtime-set! stats (+ (stat-qtime stats) duration)) ;;; ;; coarse average ;;; (stat-qcount-avg-set! stats (/ (+ (stat-qcount-avg stats) numqueries) 2)) ;;; (stat-qtime-avg-set! stats (/ (+ (stat-qtime-avg stats) duration) 2)) ;;; ;;; ;; here is where we add the stats for a given dbfile ;;; (if (not (member fname (stat-dbs stats))) ;;; (stat-dbs-set! stats (cons fname (stat-dbs stats)))) ;;; ;;; )) ;;; ;;; ;;====================================================================== ;;; ;; S E R V E R S T U F F ;;; ;;====================================================================== ;;; ;;; ;; this does NOT return! ;;; ;; ;;; (define (find-free-port-and-open acfg) ;;; (let ((port (or (area-port acfg) 3200))) ;;; (handle-exceptions ;;; exn ;;; (begin ;;; (print "INFO: cannot bind to port " (rpc:default-server-port) ", trying next port") ;;; (area-port-set! acfg (+ port 1)) ;;; (find-free-port-and-open acfg)) ;;; (rpc:default-server-port port) ;;; (area-port-set! acfg port) ;;; (tcp-read-timeout 120000) ;;; ;; ((rpc:make-server (tcp-listen port)) #t) ;;; (tcp-listen (rpc:default-server-port) ;;; )))) ;;; ;;; ;; register this node by putting a packet into the pkts dir. ;;; ;; look for other servers ;;; ;; contact other servers and compile list of servers ;;; ;; there are two types of server ;;; ;; main servers - dashboards, runners and dedicated servers - need pkt ;;; ;; passive servers - test executers, step calls, list-runs - no pkt ;;; ;; ;;; (define (register-node acfg hostip port-num) ;;; ;;(mutex-lock! (area-mutex acfg)) ;;; (let* ((server-type (area-server-type acfg)) ;; auto, main, passive (no pkt created) ;;; (best-ip (or hostip (get-my-best-address))) ;;; (mtdir (area-dbdir acfg)) ;;; (pktdir (area-pktsdir acfg))) ;; conc mtdir "/.server-pkts"))) ;;; (print "Registering node " best-ip ":" port-num) ;;; (if (not mtdir) ;; require a home for this node to put or find databases ;;; #f ;;; (begin ;;; (if (not (directory? pktdir))(create-directory pktdir)) ;;; ;; server is started, now create pkt if needed ;;; (print "Starting server in " server-type " mode with port " port-num) ;;; (if (member server-type '(auto main)) ;; TODO: if auto, count number of servers registers, if > 3 then don't put out a pkt ;;; (begin ;;; (area-pktid-set! acfg ;;; (write-alist->pkt ;;; pktdir ;;; `((hostname . ,(get-host-name)) ;;; (ipaddr . ,best-ip) ;;; (port . ,port-num) ;;; (pid . ,(current-process-id))) ;;; pktspec: *pktspec* ;;; ptype: 'server)) ;;; (area-pktfile-set! acfg (conc pktdir "/" (area-pktid acfg) ".pkt")))) ;;; (area-port-set! acfg port-num) ;;; #;(mutex-unlock! (area-mutex acfg)))))) ;;; ;;; (define *cookie-seqnum* 0) ;;; (define (make-cookie key) ;;; (set! *cookie-seqnum* (add1 *cookie-seqnum*)) ;;; ;;(print "MAKE COOKIE CALLED -- on "servkey"-"*cookie-seqnum*) ;;; (conc key "-" *cookie-seqnum*) ;;; ) ;;; ;;; ;; dispatch locally if possible ;;; ;; ;;; (define (call-deliver-response acfg ipaddr port cookie data) ;;; (if (and (equal? (area-myaddr acfg) ipaddr) ;;; (equal? (area-port acfg) port)) ;;; (deliver-response acfg cookie data) ;;; ((rpc:procedure 'response ipaddr port) cookie data))) ;;; ;;; (define (deliver-response acfg cookie data) ;;; (let ((deliver-response-start (current-milliseconds))) ;;; (thread-start! (make-thread ;;; (lambda () ;;; (let loop ((tries-left 5)) ;;; ;;(print "TOP OF DELIVER_RESPONSE LOOP; triesleft="tries-left) ;;; ;;(pp (hash-table->alist (area-cookie2mbox acfg))) ;;; (let* ((mbox (hash-table-ref/default (area-cookie2mbox acfg) cookie #f))) ;;; (cond ;;; ((eq? 0 tries-left) ;;; (print "ulex:deliver-response: I give up. Mailbox never appeared. cookie="cookie) ;;; ) ;;; (mbox ;;; ;;(print "got mbox="mbox" got data="data" send.") ;;; (mailbox-send! mbox data)) ;;; (else ;;; ;;(print "no mbox yet. look for "cookie) ;;; (thread-sleep! (/ (- 6 tries-left) 10)) ;;; (loop (sub1 tries-left)))))) ;;; ;; (debug-pp (list (conc "ulex:deliver-response took " (- (current-milliseconds) deliver-response-start) " ms, cookie=" cookie " data=") data)) ;;; (sdbg> "deliver-response" "mailbox-send" deliver-response-start #f #f cookie) ;;; ) ;;; (conc "deliver-response thread for cookie="cookie)))) ;;; #t) ;;; ;;; ;; action: ;;; ;; immediate - quick actions, no need to put in queues ;;; ;; dbwrite - put in dbwrite queue ;;; ;; dbread - put in dbread queue ;;; ;; oslong - os actions, e.g. du, that could take a long time ;;; ;; osshort - os actions that should be quick, e.g. df ;;; ;; ;;; (define (request acfg from-ipaddr from-port servkey action cookie fname params) ;; std-peer-handler ;;; ;; NOTE: Use rpc:current-peer for getting return address ;;; (let* ((std-peer-handler-start (current-milliseconds)) ;;; ;; (raw-data (alist-ref 'data dat)) ;;; (rdat (hash-table-ref/default ;;; (area-rtable acfg) action #f)) ;; this looks up the sql query or other details indexed by the action ;;; (witem (make-witem ripaddr: from-ipaddr ;; rhost: from-host ;;; rport: from-port action: action ;;; rdat: rdat cookie: cookie ;;; servkey: servkey data: params ;; TODO - rename data to params ;;; caller: (rpc:current-peer)))) ;;; (if (not (equal? servkey (area-pktid acfg))) ;;; `(#f . ,(conc "I don't know you servkey=" servkey ", pktid=" (area-pktid acfg))) ;; immediately return this ;;; (let* ((ctype (if rdat ;;; (calldat-ctype rdat) ;; is this necessary? these should be identical ;;; action))) ;;; (sdbg> "std-peer-handler" "immediate" std-peer-handler-start #f #f) ;;; (case ctype ;;; ;; (dbwrite acfg rdat (cons from-ipaddr from-port) data))) ;;; ((full-ping) `(#t "ack to full ping" ,(work-queue-add acfg fname witem) ,cookie)) ;;; ((response) `(#t "ack from requestor" ,(deliver-response acfg fname params))) ;;; ((dbwrite) `(#t "db write submitted" ,(work-queue-add acfg fname witem) ,cookie)) ;;; ((dbread) `(#t "db read submitted" ,(work-queue-add acfg fname witem) ,cookie )) ;;; ((dbrw) `(#t "db read/write submitted" ,cookie)) ;;; ((osshort) `(#t "os short submitted" ,cookie)) ;;; ((oslong) `(#t "os long submitted" ,cookie)) ;;; (else `(#f "unrecognised action" ,ctype))))))) ;;; ;;; ;; Call this to start the actual server ;;; ;; ;;; ;; start_server ;;; ;; ;;; ;; mode: ' ;;; ;; handler: proc which takes pktrecieved as argument ;;; ;; ;;; ;;; (define (start-server acfg) ;;; (let* ((conn (find-free-port-and-open acfg)) ;;; (port (area-port acfg))) ;;; (rpc:publish-procedure! ;;; 'delist-db ;;; (lambda (fname) ;;; (hash-table-delete! (area-dbs acfg) fname))) ;;; (rpc:publish-procedure! ;;; 'calling-addr ;;; (lambda () ;;; (rpc:current-peer))) ;;; (rpc:publish-procedure! ;;; 'ping ;;; (lambda ()(real-ping acfg))) ;;; (rpc:publish-procedure! ;;; 'request ;;; (lambda (from-addr from-port servkey action cookie dbname params) ;;; (request acfg from-addr from-port servkey action cookie dbname params))) ;;; (rpc:publish-procedure! ;;; 'response ;;; (lambda (cookie res-dat) ;;; (deliver-response acfg cookie res-dat))) ;;; (area-ready-set! acfg #t) ;;; (area-conn-set! acfg conn) ;;; ((rpc:make-server conn) #f)));; ((tcp-listen (rpc:default-server-port)) #t) ;;; ;;; ;;; (define (launch acfg) ;; #!optional (proc std-peer-handler)) ;;; (print "starting launch") ;;; (update-known-servers acfg) ;; gotta do this on every start (thus why limit number of publicised servers) ;;; #;(let ((original-handler (current-exception-handler))) ;; is th ;;; (lambda (exception) ;;; (server-exit-procedure) ;;; (original-handler exception))) ;;; (on-exit (lambda () ;;; (shutdown acfg))) ;; (finalize-all-db-handles acfg))) ;;; ;; set up the rpc handler ;;; (let* ((th1 (make-thread ;;; (lambda ()(start-server acfg)) ;;; "server thread")) ;;; (th2 (make-thread ;;; (lambda () ;;; (print "th2 starting") ;;; (let loop () ;;; (work-queue-processor acfg) ;;; (print "work-queue-processor crashed!") ;;; (loop))) ;;; "work queue thread"))) ;;; (thread-start! th1) ;;; (thread-start! th2) ;;; (let loop () ;;; (thread-sleep! 0.025) ;;; (if (area-ready acfg) ;;; #t ;;; (loop))) ;;; ;; attempt to fix my address ;;; (let* ((all-addr (get-all-ips-sorted))) ;; could use (tcp-addresses conn)? ;;; (let loop ((rem-addrs all-addr)) ;;; (if (null? rem-addrs) ;;; (begin ;;; (print "ERROR: Failed to figure out the ip address of myself as a server. Giving up.") ;;; (exit 1)) ;; BUG Changeme to raising an exception ;;; ;;; (let* ((addr (car rem-addrs)) ;;; (good-addr (handle-exceptions ;;; exn ;;; #f ;;; ((rpc:procedure 'calling-addr addr (area-port acfg)))))) ;;; (if good-addr ;;; (begin ;;; (print "Got good-addr of " good-addr) ;;; (area-myaddr-set! acfg good-addr)) ;;; (loop (cdr rem-addrs))))))) ;;; (register-node acfg (area-myaddr acfg)(area-port acfg)) ;;; (print "INFO: Server started on " (area-myaddr acfg) ":" (area-port acfg)) ;;; ;; (update-known-servers acfg) ;; gotta do this on every start (thus why limit number of publicised servers) ;;; )) ;;; ;;; (define (clear-server-pkt acfg) ;;; (let ((pktf (area-pktfile acfg))) ;;; (if pktf (delete-file* pktf)))) ;;; ;;; (define (shutdown acfg) ;;; (let (;;(conn (area-conn acfg)) ;;; (pktf (area-pktfile acfg)) ;;; (port (area-port acfg))) ;;; (if pktf (delete-file* pktf)) ;;; (send-all "imshuttingdown") ;;; ;; (rpc:close-all-connections!) ;; don't know if this is actually needed ;;; (finalize-all-db-handles acfg))) ;;; ;;; (define (send-all msg) ;;; #f) ;;; ;;; ;; given a area record look up all the packets ;;; ;; ;;; (define (get-all-server-pkts acfg) ;;; (let ((all-pkt-files (glob (conc (area-pktsdir acfg) "/*.pkt")))) ;;; (map (lambda (pkt-file) ;;; (read-pkt->alist pkt-file pktspec: *pktspec*)) ;;; all-pkt-files))) ;;; ;;; #;((Z . "9a0212302295a19610d5796fce0370fa130758e9") ;;; (port . "34827") ;;; (pid . "28748") ;;; (hostname . "zeus") ;;; (T . "server") ;;; (D . "1549427032.0")) ;;; ;;; #;(define (get-my-best-address) ;;; (let ((all-my-addresses (get-all-ips))) ;; (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) ;;; (ip->string (car all-my-addresses))) ;; only one to choose from, just go with it ;;; (else ;;; (ip->string (car (filter (lambda (x) ;; take any but 127. ;;; (not (eq? (u8vector-ref x 0) 127))) ;;; all-my-addresses))))))) ;;; ;;; ;; whoami? I am my pkt ;;; ;; ;;; (define (whoami? acfg) ;;; (hash-table-ref/default (area-hosts acfg)(area-pktid acfg) #f)) ;;; ;;; ;;====================================================================== ;;; ;; "Client side" operations ;;; ;;====================================================================== ;;; ;;; (define (safe-call call-key host port . params) ;;; (handle-exceptions ;;; exn ;;; (begin ;;; (print "Call " call-key " to " host ":" port " failed") ;;; #f) ;;; (apply (rpc:procedure call-key host port) params))) ;;; ;;; ;; ;; convert to/from string / sexpr ;;; ;; ;;; ;; (define (string->sexpr str) ;;; ;; (if (string? str) ;;; ;; (with-input-from-string str read) ;;; ;; str)) ;;; ;; ;;; ;; (define (sexpr->string s) ;;; ;; (with-output-to-string (lambda ()(write s)))) ;;; ;;; ;; is the server alive? ;;; ;; ;;; (define (ping acfg host port) ;;; (let* ((myaddr (area-myaddr acfg)) ;;; (myport (area-port acfg)) ;;; (start-time (current-milliseconds)) ;;; (res (if (and (equal? myaddr host) ;;; (equal? myport port)) ;;; (real-ping acfg) ;;; ((rpc:procedure 'ping host port))))) ;;; (cons (- (current-milliseconds) start-time) ;;; res))) ;;; ;;; ;; returns ( ipaddr port alist-fname=>randnum ) ;;; (define (real-ping acfg) ;;; `(,(area-myaddr acfg) ,(area-port acfg) ,(get-host-stats acfg))) ;;; ;;; ;; is the server alive AND the queues processing? ;;; ;; ;;; #;(define (full-ping acfg servpkt) ;;; (let* ((start-time (current-milliseconds)) ;;; (res (send-message acfg servpkt '(full-ping) 'full-ping))) ;;; (cons (- (current-milliseconds) start-time) ;;; res))) ;; (equal? res "got ping")))) ;;; ;;; ;;; ;; look up all pkts and get the server id (the hash), port, host/ip ;;; ;; store this info in acfg ;;; ;; return the number of responsive servers found ;;; ;; ;;; ;; DO NOT VERIFY THAT THE SERVER IS ALIVE HERE. This is called at times where the current server is not yet alive and cannot ping itself ;;; ;; ;;; (define (update-known-servers acfg) ;;; ;; readll all pkts ;;; ;; foreach pkt; if it isn't me ping the server; if alive, add to hosts hash, else rm the pkt ;;; (let* ((start-time (current-milliseconds)) ;;; (all-pkts (delete-duplicates ;;; (append (get-all-server-pkts acfg) ;;; (hash-table-values (area-hosts acfg))))) ;;; (hostshash (area-hosts acfg)) ;;; (my-id (area-pktid acfg)) ;;; (pktsdir (area-pktsdir acfg)) ;; needed to remove pkts from non-responsive servers ;;; (numsrvs 0) ;;; (delpkt (lambda (pktsdir sid) ;;; (print "clearing out server " sid) ;;; (delete-file* (conc pktsdir "/" sid ".pkt")) ;;; (hash-table-delete! hostshash sid)))) ;;; (area-last-srvup-set! acfg (current-seconds)) ;;; (for-each ;;; (lambda (servpkt) ;;; (if (list? servpkt) ;;; ;; (pp servpkt) ;;; (let* ((shost (alist-ref 'ipaddr servpkt)) ;;; (sport (any->number (alist-ref 'port servpkt))) ;;; (res (handle-exceptions ;;; exn ;;; (begin ;;; ;; (print "INFO: bad server on " shost ":" sport) ;;; #f) ;;; (ping acfg shost sport))) ;;; (sid (alist-ref 'Z servpkt)) ;; Z code is our name for the server ;;; (url (conc shost ":" sport)) ;;; ) ;;; #;(if (or (not res) ;;; (null? res)) ;;; (begin ;;; (print "STRANGE: ping of " url " gave " res))) ;;; ;;; ;; (print "Got " res " from " shost ":" sport) ;;; (match res ;;; ((qduration . payload) ;;; ;; (print "Server pkt:" (alist-ref 'ipaddr servpkt) ":" (alist-ref 'port servpkt) ;;; ;; (if payload ;;; ;; "Success" "Fail")) ;;; (match payload ;;; ((host port stats) ;;; ;; (print "From " host ":" port " got stats: " stats) ;;; (if (and host port stats) ;;; (let ((url (conc host ":" port))) ;;; (hash-table-set! hostshash sid servpkt) ;;; ;; store based on host:port ;;; (hash-table-set! (area-hoststats acfg) sid stats)) ;;; (print "missing data from the server, not sure what that means!")) ;;; (set! numsrvs (+ numsrvs 1))) ;;; (#f ;;; (print "Removing pkt " sid " due to #f from server or failed ping") ;;; (delpkt pktsdir sid)) ;;; (else ;;; (print "Got ")(pp res)(print " from server ")(pp servpkt) " but response did not match (#f/#t . msg)"))) ;;; (else ;;; ;; here we delete the pkt - can't reach the server, remove it ;;; ;; however this logic is inadequate. we should mark the server as checked ;;; ;; and not good, if it happens a second time - then remove the pkt ;;; ;; or something similar. I.e. don't be too quick to assume the server is wedged or dead ;;; ;; could be it is simply too busy to reply ;;; (let ((bad-pings (hash-table-ref/default (area-health acfg) url 0))) ;;; (if (> bad-pings 1) ;; two bad pings - remove pkt ;;; (begin ;;; (print "INFO: " bad-pings " bad responses from " url ", deleting pkt " sid) ;;; (delpkt pktsdir sid)) ;;; (begin ;;; (print "INFO: " bad-pings " bad responses from " shost ":" sport " not deleting pkt yet") ;;; (hash-table-set! (area-health acfg) ;;; url ;;; (+ (hash-table-ref/default (area-health acfg) url 0) 1)) ;;; )) ;;; )))) ;;; ;; servpkt is not actually a pkt? ;;; (begin ;;; (print "Bad pkt " servpkt)))) ;;; all-pkts) ;;; (sdbg> "update-known-servers" "end" start-time #f #f " found " numsrvs ;;; " servers, pkts: " (map (lambda (p) ;;; (alist-ref 'Z p)) ;;; all-pkts)) ;;; numsrvs)) ;;; ;;; (defstruct srvstat ;;; (numfiles 0) ;; number of db files handled by this server - subtract 1 for the db being currently looked at ;;; (randnum #f) ;; tie breaker number assigned to by the server itself - applies only to the db under consideration ;;; (pkt #f)) ;; the server pkt ;;; ;;; ;;(define (srv->srvstat srvpkt) ;;; ;;; ;; Get the server best for given dbname and key ;;; ;; ;;; ;; NOTE: key is not currently used. The key points to the kind of query, this may be useful for directing read-only queries. ;;; ;; ;;; (define (get-best-server acfg dbname key) ;;; (let* (;; (servers (hash-table-values (area-hosts acfg))) ;;; (servers (area-hosts acfg)) ;;; (skeys (sort (hash-table-keys servers) string>=?)) ;; a stable listing ;;; (start-time (current-milliseconds)) ;;; (srvstats (make-hash-table)) ;; srvid => srvstat ;;; (url (conc (area-myaddr acfg) ":" (area-port acfg)))) ;;; ;; (print "scores for " dbname ": " (map (lambda (k)(cons k (calc-server-score acfg dbname k))) skeys)) ;;; (if (null? skeys) ;;; (if (> (update-known-servers acfg) 0) ;;; (get-best-server acfg dbname key) ;; some risk of infinite loop here, TODO add try counter ;;; (begin ;;; (print "ERROR: no server found!") ;; since this process is also a server this should never happen ;;; #f)) ;;; (begin ;;; ;; (print "in get-best-server with skeys=" skeys) ;;; (if (> (- (current-seconds) (area-last-srvup acfg)) 10) ;;; (begin ;;; (update-known-servers acfg) ;;; (sdbg> "get-best-server" "update-known-servers" start-time #f #f))) ;;; ;;; ;; for each server look at the list of dbfiles, total number of dbs being handled ;;; ;; and the rand number, save the best host ;;; ;; also do a delist-db for each server dbfile not used ;;; (let* ((best-server #f) ;;; (servers-to-delist (make-hash-table))) ;;; (for-each ;;; (lambda (srvid) ;;; (let* ((server (hash-table-ref/default servers srvid #f)) ;;; (stats (hash-table-ref/default (area-hoststats acfg) srvid '(())))) ;;; ;; (print "stats: " stats) ;;; (if server ;;; (let* ((dbweights (car stats)) ;;; (srvload (length (filter (lambda (x)(not (equal? dbname (car x)))) dbweights))) ;;; (dbrec (alist-ref dbname dbweights equal?)) ;; get the pair with fname . randscore ;;; (randnum (if dbrec ;;; dbrec ;; (cdr dbrec) ;;; 0))) ;;; (hash-table-set! srvstats srvid (make-srvstat numfiles: srvload randnum: randnum pkt: server)))))) ;;; skeys) ;;; ;;; (let* ((sorted (sort (hash-table-values srvstats) ;;; (lambda (a b) ;;; (let ((numfiles-a (srvstat-numfiles a)) ;;; (numfiles-b (srvstat-numfiles b)) ;;; (randnum-a (srvstat-randnum a)) ;;; (randnum-b (srvstat-randnum b))) ;;; (if (< numfiles-a numfiles-b) ;; Note, I don't think adding an offset works here. Goal was only move file handling to a different server if it has 2 less ;;; #t ;;; (if (and (equal? numfiles-a numfiles-b) ;;; (< randnum-a randnum-b)) ;;; #t ;;; #f)))))) ;;; (best (if (null? sorted) ;;; (begin ;;; (print "ERROR: should never be null due to self as server.") ;;; #f) ;;; (srvstat-pkt (car sorted))))) ;;; #;(print "SERVER(" url "): " dbname ": " (map (lambda (srv) ;;; (let ((p (srvstat-pkt srv))) ;;; (conc (alist-ref 'ipaddr p) ":" (alist-ref 'port p) ;;; "(" (srvstat-numfiles srv)","(srvstat-randnum srv)")"))) ;;; sorted)) ;;; best)))))) ;;; ;;; ;; send out an "I'm about to exit notice to all known servers" ;;; ;; ;;; (define (death-imminent acfg) ;;; '()) ;;; ;;; ;;====================================================================== ;;; ;; U L E X - T H E I N T E R E S T I N G S T U F F ! ! ;;; ;;====================================================================== ;;; ;;; ;; register a handler ;;; ;; NOTES: ;;; ;; dbinitsql is reserved for a list of sql statements for initializing the db ;;; ;; dbinitfn is reserved for a db init function, if exists called after dbinitsql ;;; ;; ;;; (define (register acfg key obj #!optional (ctype 'dbwrite)) ;;; (let ((ht (area-rtable acfg))) ;;; (if (hash-table-exists? ht key) ;;; (print "WARNING: redefinition of entry " key)) ;;; (hash-table-set! ht key (make-calldat obj: obj ctype: ctype)))) ;;; ;;; ;; usage: register-batch acfg '((key1 . sql1) (key2 . sql2) ... ) ;;; ;; NB// obj is often an sql query ;;; ;; ;;; (define (register-batch acfg ctype data) ;;; (let ((ht (area-rtable acfg))) ;;; (map (lambda (dat) ;;; (hash-table-set! ht (car dat)(make-calldat obj: (cdr dat) ctype: ctype))) ;;; data))) ;;; ;;; (define (initialize-area-calls-from-specfile area specfile) ;;; (let* ((callspec (with-input-from-file specfile read ))) ;;; (for-each (lambda (group) ;;; (register-batch ;;; area ;;; (car group) ;;; (cdr group))) ;;; callspec))) ;;; ;;; ;; get-rentry ;;; ;; ;;; (define (get-rentry acfg key) ;;; (hash-table-ref/default (area-rtable acfg) key #f)) ;;; ;;; (define (get-rsql acfg key) ;;; (let ((cdat (get-rentry acfg key))) ;;; (if cdat ;;; (calldat-obj cdat) ;;; #f))) ;;; ;;; ;;; ;;; ;; blocking call: ;;; ;; client server ;;; ;; ------ ------ ;;; ;; call() ;;; ;; send-message() ;;; ;; nmsg-send() ;;; ;; nmsg-receive() ;;; ;; nmsg-respond(ack,cookie) ;;; ;; ack, cookie ;;; ;; mbox-thread-wait(cookie) ;;; ;; nmsg-send(client,cookie,result) ;;; ;; nmsg-respond(ack) ;;; ;; return result ;;; ;; ;;; ;; reserved action: ;;; ;; 'immediate ;;; ;; 'dbinitsql ;;; ;; ;;; (define (call acfg dbname action params #!optional (count 0)) ;;; (let* ((call-start-time (current-milliseconds)) ;;; (srv (get-best-server acfg dbname action)) ;;; (post-get-start-time (current-milliseconds)) ;;; (rdat (hash-table-ref/default (area-rtable acfg) action #f)) ;;; (myid (trim-pktid (area-pktid acfg))) ;;; (srvid (trim-pktid (alist-ref 'Z srv))) ;;; (cookie (make-cookie myid))) ;;; (sdbg> "call" "get-best-server" call-start-time #f call-start-time " from: " myid " to server: " srvid " for " dbname " action: " action " params: " params " rdat: " rdat) ;;; (print "INFO: call to " (alist-ref 'ipaddr srv) ":" (alist-ref 'port srv) " from " (area-myaddr acfg) ":" (area-port acfg) " for " dbname) ;;; (if (and srv rdat) ;; need both to dispatch a request ;;; (let* ((ripaddr (alist-ref 'ipaddr srv)) ;;; (rsrvid (alist-ref 'Z srv)) ;;; (rport (any->number (alist-ref 'port srv))) ;;; (res-full (if (and (equal? ripaddr (area-myaddr acfg)) ;;; (equal? rport (area-port acfg))) ;;; (request acfg ripaddr rport (area-pktid acfg) action cookie dbname params) ;;; (safe-call 'request ripaddr rport ;;; (area-myaddr acfg) ;;; (area-port acfg) ;;; #;(area-pktid acfg) ;;; rsrvid ;;; action cookie dbname params)))) ;;; ;; (print "res-full: " res-full) ;;; (match res-full ;;; ((response-ok response-msg rem ...) ;;; (let* ((send-message-time (current-milliseconds)) ;;; ;; (match res-full ;;; ;; ((response-ok response-msg) ;;; ;; (response-ok (car res-full)) ;;; ;; (response-msg (cadr res-full) ;;; ) ;;; ;; (res (take res-full 3))) ;; ctype == action, TODO: converge on one term <<=== what was this? BUG ;;; ;; (print "ulex:call: send-message took " (- send-message-time post-get-start-time) " ms params=" params) ;;; (sdbg> "call" "send-message" post-get-start-time #f call-start-time) ;;; (cond ;;; ((not response-ok) #f) ;;; ((member response-msg '("db read submitted" "db write submitted")) ;;; (let* ((cookie-id (cadddr res-full)) ;;; (mbox (make-mailbox)) ;;; (mbox-time (current-milliseconds))) ;;; (hash-table-set! (area-cookie2mbox acfg) cookie-id mbox) ;;; (let* ((mbox-timeout-secs 20) ;;; (mbox-timeout-result 'MBOX_TIMEOUT) ;;; (res (mailbox-receive! mbox mbox-timeout-secs mbox-timeout-result)) ;;; (mbox-receive-time (current-milliseconds))) ;;; (hash-table-delete! (area-cookie2mbox acfg) cookie-id) ;;; (sdbg> "call" "mailbox-receive" mbox-time #f call-start-time " from: " myid " to server: " srvid " for " dbname) ;;; ;; (print "ulex:call mailbox-receive took " (- mbox-receive-time mbox-time) "ms params=" params) ;;; res))) ;;; (else ;;; (print "Unhandled response \""response-msg"\"") ;;; #f)) ;;; ;; depending on what action (i.e. ctype) is we will block here waiting for ;;; ;; all the data (mechanism to be determined) ;;; ;; ;;; ;; if res is a "working on it" then wait ;;; ;; wait for result ;;; ;; mailbox thread wait on ;;; ;;; ;; if res is a "can't help you" then try a different server ;;; ;; if res is a "ack" (e.g. for one-shot requests) then return res ;;; )) ;;; (else ;;; (if (< count 10) ;;; (let* ((url (conc (alist-ref 'ipaddr srv) ":" (alist-ref 'port srv)))) ;;; (thread-sleep! 1) ;;; (print "ERROR: Bad result from " url ", dbname: " dbname ", action: " action ", params: " params ". Trying again in 1 second.") ;;; (call acfg dbname action params (+ count 1))) ;;; (begin ;;; (error (conc "ERROR: " count " tries, still have improper response res-full=" res-full))))))) ;;; (begin ;;; (if (not rdat) ;;; (print "ERROR: action " action " not registered.") ;;; (if (< count 10) ;;; (begin ;;; (thread-sleep! 1) ;;; (area-hosts-set! acfg (make-hash-table)) ;; clear out all known hosts ;;; (print "ERROR: no server found, srv=" srv ", trying again in 1 seconds") ;;; (call acfg dbname action params (+ count 1))) ;;; (begin ;;; (error (conc "ERROR: no server found after 10 tries, srv=" srv ", giving up.")) ;;; #;(error "No server available")))))))) ;;; ;;; ;;; ;;====================================================================== ;;; ;; U T I L I T I E S ;;; ;;====================================================================== ;;; ;;; ;; get a signature for identifing this process ;;; ;; ;;; (define (get-process-signature) ;;; (cons (get-host-name)(current-process-id))) ;;; ;;; ;;====================================================================== ;;; ;; S Y S T E M S T U F F ;;; ;;====================================================================== ;;; ;;; ;; get normalized cpu load by reading from /proc/loadavg and ;;; ;; /proc/cpuinfo return all three values and the number of real cpus ;;; ;; and the number of threads returns alist '((adj-cpu-load ;;; ;; . normalized-proc-load) ... etc. keys: adj-proc-load, ;;; ;; adj-core-load, 1m-load, 5m-load, 15m-load ;;; ;; ;;; (define (get-normalized-cpu-load) ;;; (let ((res (get-normalized-cpu-load-raw)) ;;; (default `((adj-proc-load . 2) ;; there is no right answer ;;; (adj-core-load . 2) ;;; (1m-load . 2) ;;; (5m-load . 0) ;; causes a large delta - thus causing default of throttling if stuff goes wrong ;;; (15m-load . 0) ;;; (proc . 1) ;;; (core . 1) ;;; (phys . 1) ;;; (error . #t)))) ;;; (cond ;;; ((and (list? res) ;;; (> (length res) 2)) ;;; res) ;;; ((eq? res #f) default) ;; add messages? ;;; ((eq? res #f) default) ;; this would be the #eof ;;; (else default)))) ;;; ;;; (define (get-normalized-cpu-load-raw) ;;; (let* ((actual-host (get-host-name))) ;; #f is localhost ;;; (let ((data (append ;;; (with-input-from-file "/proc/loadavg" read-lines) ;;; (with-input-from-file "/proc/cpuinfo" read-lines) ;;; (list "end"))) ;;; (load-rx (regexp "^([\\d\\.]+)\\s+([\\d\\.]+)\\s+([\\d\\.]+)\\s+.*$")) ;;; (proc-rx (regexp "^processor\\s+:\\s+(\\d+)\\s*$")) ;;; (core-rx (regexp "^core id\\s+:\\s+(\\d+)\\s*$")) ;;; (phys-rx (regexp "^physical id\\s+:\\s+(\\d+)\\s*$")) ;;; (max-num (lambda (p n)(max (string->number p) n)))) ;;; ;; (print "data=" data) ;;; (if (null? data) ;; something went wrong ;;; #f ;;; (let loop ((hed (car data)) ;;; (tal (cdr data)) ;;; (loads #f) ;;; (proc-num 0) ;; processor includes threads ;;; (phys-num 0) ;; physical chip on motherboard ;;; (core-num 0)) ;; core ;;; ;; (print hed ", " loads ", " proc-num ", " phys-num ", " core-num) ;;; (if (null? tal) ;; have all our data, calculate normalized load and return result ;;; (let* ((act-proc (+ proc-num 1)) ;;; (act-phys (+ phys-num 1)) ;;; (act-core (+ core-num 1)) ;;; (adj-proc-load (/ (car loads) act-proc)) ;;; (adj-core-load (/ (car loads) act-core)) ;;; (result ;;; (append (list (cons 'adj-proc-load adj-proc-load) ;;; (cons 'adj-core-load adj-core-load)) ;;; (list (cons '1m-load (car loads)) ;;; (cons '5m-load (cadr loads)) ;;; (cons '15m-load (caddr loads))) ;;; (list (cons 'proc act-proc) ;;; (cons 'core act-core) ;;; (cons 'phys act-phys))))) ;;; result) ;;; (regex-case ;;; hed ;;; (load-rx ( x l1 l5 l15 ) (loop (car tal)(cdr tal)(map string->number (list l1 l5 l15)) proc-num phys-num core-num)) ;;; (proc-rx ( x p ) (loop (car tal)(cdr tal) loads (max-num p proc-num) phys-num core-num)) ;;; (phys-rx ( x p ) (loop (car tal)(cdr tal) loads proc-num (max-num p phys-num) core-num)) ;;; (core-rx ( x c ) (loop (car tal)(cdr tal) loads proc-num phys-num (max-num c core-num))) ;;; (else ;;; (begin ;;; ;; (print "NO MATCH: " hed) ;;; (loop (car tal)(cdr tal) loads proc-num phys-num core-num)))))))))) ;;; ;;; (define (get-host-stats acfg) ;;; (let ((stats-hash (area-stats acfg))) ;;; ;; use this opportunity to remove references to dbfiles which have not been accessed in a while ;;; (for-each ;;; (lambda (dbname) ;;; (let* ((stats (hash-table-ref stats-hash dbname)) ;;; (last-access (stat-when stats))) ;;; (if (and (> last-access 0) ;; if zero then there has been no access ;;; (> (- (current-seconds) last-access) 10)) ;; not used in ten seconds ;;; (begin ;;; (print "Removing " dbname " from stats list") ;;; (hash-table-delete! stats-hash dbname) ;; remove from stats hash ;;; (stat-dbs-set! stats (hash-table-keys stats)))))) ;;; (hash-table-keys stats-hash)) ;;; ;;; `(,(hash-table->alist (area-dbs acfg)) ;; dbname => randnum ;;; ,(map (lambda (dbname) ;; dbname is the db name ;;; (cons dbname (stat-when (hash-table-ref stats-hash dbname)))) ;;; (hash-table-keys stats-hash)) ;;; (cpuload . ,(get-normalized-cpu-load))))) ;;; #;(stats . ,(map (lambda (k) ;; create an alist from the stats data ;;; (cons k (stat->alist (hash-table-ref (area-stats acfg) k)))) ;;; (hash-table-keys (area-stats acfg)))) ;;; ;;; #;(trace ;;; ;; assv ;;; ;; cdr ;;; ;; caar ;;; ;; ;; cdr ;;; ;; call ;;; ;; finalize-all-db-handles ;;; ;; get-all-server-pkts ;;; ;; get-normalized-cpu-load ;;; ;; get-normalized-cpu-load-raw ;;; ;; launch ;;; ;; nmsg-send ;;; ;; process-db-queries ;;; ;; receive-message ;;; ;; std-peer-handler ;;; ;; update-known-servers ;;; ;; work-queue-processor ;;; ) ;;; ;;; ;;====================================================================== ;;; ;; netutil ;;; ;; move this back to ulex-netutil.scm someday? ;;; ;;====================================================================== ;;; ;;; ;; #include <stdio.h> ;;; ;; #include <netinet/in.h> ;;; ;; #include <string.h> ;;; ;; #include <arpa/inet.h> ;;; ;;; (foreign-declare "#include \"sys/types.h\"") ;;; (foreign-declare "#include \"sys/socket.h\"") ;;; (foreign-declare "#include \"ifaddrs.h\"") ;;; (foreign-declare "#include \"arpa/inet.h\"") ;;; ;;; ;; get IP addresses from ALL interfaces ;;; (define get-all-ips ;;; (foreign-safe-lambda* scheme-object () ;;; " ;;; ;;; // from https://stackoverflow.com/questions/17909401/linux-c-get-default-interfaces-ip-address : ;;; ;;; ;;; C_word lst = C_SCHEME_END_OF_LIST, len, str, *a; ;;; // struct ifaddrs *ifa, *i; ;;; // struct sockaddr *sa; ;;; ;;; struct ifaddrs * ifAddrStruct = NULL; ;;; struct ifaddrs * ifa = NULL; ;;; void * tmpAddrPtr = NULL; ;;; ;;; if ( getifaddrs(&ifAddrStruct) != 0) ;;; C_return(C_SCHEME_FALSE); ;;; ;;; // for (i = ifa; i != NULL; i = i->ifa_next) { ;;; for (ifa = ifAddrStruct; ifa != NULL; ifa = ifa->ifa_next) { ;;; if (ifa->ifa_addr->sa_family==AF_INET) { // Check it is ;;; // a valid IPv4 address ;;; tmpAddrPtr = &((struct sockaddr_in *)ifa->ifa_addr)->sin_addr; ;;; char addressBuffer[INET_ADDRSTRLEN]; ;;; inet_ntop(AF_INET, tmpAddrPtr, addressBuffer, INET_ADDRSTRLEN); ;;; // printf(\"%s IP Address %s\\n\", ifa->ifa_name, addressBuffer); ;;; len = strlen(addressBuffer); ;;; a = C_alloc(C_SIZEOF_PAIR + C_SIZEOF_STRING(len)); ;;; str = C_string(&a, len, addressBuffer); ;;; lst = C_a_pair(&a, str, lst); ;;; } ;;; ;;; // else if (ifa->ifa_addr->sa_family==AF_INET6) { // Check it is ;;; // // a valid IPv6 address ;;; // tmpAddrPtr = &((struct sockaddr_in6 *)ifa->ifa_addr)->sin6_addr; ;;; // char addressBuffer[INET6_ADDRSTRLEN]; ;;; // inet_ntop(AF_INET6, tmpAddrPtr, addressBuffer, INET6_ADDRSTRLEN); ;;; //// printf(\"%s IP Address %s\\n\", ifa->ifa_name, addressBuffer); ;;; // len = strlen(addressBuffer); ;;; // a = C_alloc(C_SIZEOF_PAIR + C_SIZEOF_STRING(len)); ;;; // str = C_string(&a, len, addressBuffer); ;;; // lst = C_a_pair(&a, str, lst); ;;; // } ;;; ;;; // else { ;;; // printf(\" not an IPv4 address\\n\"); ;;; // } ;;; ;;; } ;;; ;;; freeifaddrs(ifa); ;;; C_return(lst); ;;; ;;; ")) ;;; ;;; ;; Change this to bias for addresses with a reasonable broadcast value? ;;; ;; ;;; (define (ip-pref-less? a b) ;;; (let* ((rate (lambda (ipstr) ;;; (regex-case ipstr ;;; ( "^127\\." _ 0 ) ;;; ( "^(10\\.0|192\\.168\\.)\\..*" _ 1 ) ;;; ( else 2 ) )))) ;;; (< (rate a) (rate b)))) ;;; ;;; ;;; (define (get-my-best-address) ;;; (let ((all-my-addresses (get-all-ips)) ;;; ;;(all-my-addresses-old (vector->list (hostinfo-addresses (hostname->hostinfo (get-host-name))))) ;;; ) ;;; (cond ;;; ((null? all-my-addresses) ;;; (get-host-name)) ;; no interfaces? ;;; ((eq? (length all-my-addresses) 1) ;;; (car all-my-addresses)) ;; only one to choose from, just go with it ;;; ;;; (else ;;; (car (sort all-my-addresses ip-pref-less?))) ;;; ;; (else ;;; ;; (ip->string (car (filter (lambda (x) ;; take any but 127. ;;; ;; (not (eq? (u8vector-ref x 0) 127))) ;;; ;; all-my-addresses)))) ;;; ;;; ))) ;;; ;;; (define (get-all-ips-sorted) ;;; (sort (get-all-ips) ip-pref-less?)) ;;; ;;; |