Comment: | Merged v1.81 back to trunk |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | trunk |
Files: | files | file ages | folders |
SHA1: |
b3a0155f4550f378b84d2d6e94f21075 |
User & Date: | matt on 2024-09-20 03:06:37 |
Other Links: | manifest | tags |
2024-09-20
| ||
07:03 | Updates to training doc. check-in: acb6016f77 user: matt tags: trunk | |
03:06 | Merged v1.81 back to trunk check-in: b3a0155f45 user: matt tags: trunk | |
02:51 | Updated training and official web site Leaf check-in: 49fc46636e user: matt tags: v1.81 | |
2021-09-15
| ||
15:57 | merged from v1.65 check-in: f447888296 user: mrwellan tags: trunk | |
Modified Makefile from [91af8deafd] to [b89c1a12c0].
︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 | # 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/>. # make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)' # 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 \ | > > > > > > > > | | | | > | > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # 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/>. # make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)' # rm <files>.o ; make install CSCOPTS='-profile' ; ... ; chicken-profile | less all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut recent-commits.csv : .fslckout fossil timeline -n 350 -t ci -F "%h,%a,%b,%t,\"%c\"" > recent-commits.csv SHELL=/bin/bash PREFIX=$(PWD) # CSCOPTS=-lfa2 -specialize -inline-global CSCOPTS= INSTALL=install SRCFILES = common.scm items.scm launch.scm ods.scm runconfig.scm \ server.scm configf.scm db.scm keys.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ tdb.scm mt.scm \ ezsteps.scm rmt.scm api.scm \ subrun.scm archive.scm env.scm \ diff-report.scm cgisetup/models/pgdb.scm # module source files MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm adjutant.scm mutils.scm mttop.scm tcp-transportmod.scm rmtmod.scm portlogger.scm transport-mode.scm : transport-mode.scm.template cp transport-mode.scm.template transport-mode.scm dashboard-transport-mode.scm : dashboard-transport-mode.scm.template cp dashboard-transport-mode.scm.template dashboard-transport-mode.scm mtest : transport-mode.scm dboard : dashboard-transport-mode.scm # dbmod.import.o is just a hack here mofiles/portlogger.o : mofiles/dbmod.o mofiles/dbfile.o : \ mofiles/debugprint.o mofiles/commonmod.o mofiles/dbmod.o : mofiles/dbfile.o mofiles/commonmod.o : mofiles/debugprint.o configf.o : commonmod.import.o mofiles/dbfile.o : mofiles/debugprint.o mofiles/rmtmod.o mofiles/dbmod.o : mofiles/dbfile.o mofiles/commonmod.o mofiles/debugprint.o db.o : mofiles/dbmod.o mofiles/dbfile.o mofiles/debugprint.o : mofiles/mtargs.o mofiles/tcp-transportmod.o : mofiles/portlogger.o # 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 \ |
︙ | ︙ | |||
53 54 55 56 57 58 59 | # 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 | | | > | < < | | | | < | | | | < | | | | < | | | < | | | < | | | | | | | | | | | | | | | | | > | > > > > > > > | | > > | 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 | # 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 %.import.scm mofiles/%.o : %.scm @mkdir -p mofiles csc $(CSCOPTS) -J -c $< -o mofiles/$*.o @if [[ -e $*.import.scm ]];then touch $*.import.scm;fi # 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 if [[ -e .fslckout ]];then fossil info|grep checkout:| awk '{print $$2}';else echo "na";fi) ifeq ($(MTESTHASH),) $(error MTESTHASH is broken!) endif # CSIPATH=$(shell which csi) # CKPATH=$(shell dirname $(shell dirname $(CSIPATH))) # ARCHSTR=$(shell uname -m)_$(shell uname -r) # BASH_MACHTYPE=$(shell bash -c "echo \$$MACHTYPE") # ARCHSTR=$(BASH_MACHTYPE)_$(shell lsb_release -sr) ARCHSTR=$(shell if [[ -e /usr/bin/sw_vers ]]; then /usr/bin/sw_vers -productVersion; else lsb_release -sr; fi) # ARCHSTR=$(shell bash -c "echo \$$MACHTYPE") PNGFILES = $(shell cd docs/manual;ls *png) mtest: $(OFILES) readline-fix.scm $(MOFILES) $(MOIMPFILES) megatest.o megatest-version.scm 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) $(MOIMPFILES) megatest-fossil-hash.scm mtut.scm megatest-version.scm csc $(CSCOPTS) $(OFILES) $(MOFILES) $(MOIMPFILES) mtut.scm -o mtut # include makefile.inc # TCMTOBJS = \ # api.o \ # archive.o \ # cgisetup/models/pgdb.o \ # common.o \ # configf.o \ # db.o \ # env.o \ # items.o \ # keys.o \ # launch.o \ # margs.o \ # mt.o \ # ods.o \ # process.o \ # rmt.o \ # runconfig.o \ # runs.o \ # server.o \ # tasks.o \ # tdb.o \ # tests.o \ # subrun.o \ # ezsteps.o # # # mofiles/rmtmod.o \ # # mofiles/commonmod.o \ # # tcmt : $(TCMTOBJS) tcmt.scm megatest-version.scm $(MOFILES) $(MOIMPFILES) # 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 cp utils/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 mofiles/commonmod.o : mofiles/debugprint.o megatest-fossil-hash.scm common.o : mofiles/commonmod.o # mofiles/dbmod.o : mofiles/configfmod.o # 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 db.o api.o : mofiles/dbmod.o mofiles/dbfile.o mofiles/debugprint.o mofiles/commonmod.o dbmod.import.o tests.o tasks.o dashboard-tasks.o : task_records.scm runs.o : test_records.scm # mofiles-made : $(MOFILES) # make $(MOIMPFILES) # touch mofiles-made megatest.o : megatest-fossil-hash.scm megatest-version.scm $(MOFILES) $(MOIMPFILES) rmt.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.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 megatest-version.scm common_records.scm : altdb.scm mofiles/dbfile.o : mofiles/commonmod.o # mofiles/stml2.o : mofiles/cookie.o # configf.o : mofiles/commonmod.o vg.o dashboard.o : vg_records.scm megatest-version.scm dcommon.o : run_records.scm |
︙ | ︙ | |||
244 245 246 247 248 249 250 | $(PREFIX)/bin/mtexec : $(PREFIX)/bin/.$(ARCHSTR)/mtexec utils/mk_wrapper utils/mk_wrapper $(PREFIX) mtexec $(PREFIX)/bin/mtexec chmod a+x $(PREFIX)/bin/mtexec # tcmt | | | | | | | | 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 | $(PREFIX)/bin/mtexec : $(PREFIX)/bin/.$(ARCHSTR)/mtexec utils/mk_wrapper utils/mk_wrapper $(PREFIX) mtexec $(PREFIX)/bin/mtexec chmod a+x $(PREFIX)/bin/mtexec # tcmt # $(PREFIX)/bin/.$(ARCHSTR)/tcmt : tcmt # $(INSTALL) tcmt $(PREFIX)/bin/.$(ARCHSTR)/tcmt # # $(PREFIX)/bin/tcmt : $(PREFIX)/bin/.$(ARCHSTR)/tcmt utils/mk_wrapper # utils/mk_wrapper $(PREFIX) tcmt $(PREFIX)/bin/tcmt # chmod a+x $(PREFIX)/bin/tcmt $(PREFIX)/bin/mt_laststep : utils/mt_laststep $(INSTALL) $< $@ chmod a+x $@ $(PREFIX)/bin/mt_runstep : utils/mt_runstep $(INSTALL) $< $@ |
︙ | ︙ | |||
290 291 292 293 294 295 296 297 298 299 300 301 302 303 | $(PREFIX)/bin/nbfind : utils/nbfind $(INSTALL) $< $@ chmod a+x $@ $(PREFIX)/bin/mtrunner : utils/mtrunner $(INSTALL) $< $@ chmod a+x $@ deploytarg/nbfake : utils/nbfake $(INSTALL) $< $@ chmod a+x $@ deploytarg/viewscreen : utils/viewscreen $(INSTALL) $< $@ | > > > > > > > > > > > > | 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 | $(PREFIX)/bin/nbfind : utils/nbfind $(INSTALL) $< $@ chmod a+x $@ $(PREFIX)/bin/mtrunner : utils/mtrunner $(INSTALL) $< $@ chmod a+x $@ $(PREFIX)/bin/mt-old-to-new.sh : utils/mt-old-to-new.sh $(INSTALL) $< $@ chmod a+x $@ $(PREFIX)/bin/mt-new-to-old.sh : utils/mt-new-to-old.sh $(INSTALL) $< $@ chmod a+x $@ $(PREFIX)/bin/convert-db.sh : utils/convert-db.sh $(INSTALL) $< $@ chmod a+x $@ deploytarg/nbfake : utils/nbfake $(INSTALL) $< $@ chmod a+x $@ deploytarg/viewscreen : utils/viewscreen $(INSTALL) $< $@ |
︙ | ︙ | |||
314 315 316 317 318 319 320 | # install dashboard as dboard so wrapper script can be called dashboard $(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES) utils/mk_wrapper utils/mk_wrapper $(PREFIX) dboard $(PREFIX)/bin/dashboard chmod a+x $(PREFIX)/bin/dashboard $(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard | < < < < < < < > | | > > | | > > | | > < > > | < > > > > > | 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 | # install dashboard as dboard so wrapper script can be called dashboard $(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES) utils/mk_wrapper utils/mk_wrapper $(PREFIX) dboard $(PREFIX)/bin/dashboard chmod a+x $(PREFIX)/bin/dashboard $(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so : lib/libpangox-1.0.so if [[ $(ARCHSTR) == 12.5 ]]; then \ mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib; \ $(INSTALL) lib/libpangox-1.0.so $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so; \ fi $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so.0 : lib/libpangox-1.0.so.0 if [[ $(ARCHSTR) == 12.5 ]]; then \ mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib; \ $(INSTALL) lib/libpangox-1.0.so.0 $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so.0; \ fi $(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0 : lib/libxcb-xlib.so.0 if [[ $(ARCHSTR) == 12.5 ]]; then \ mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib; \ $(INSTALL) lib/libxcb-xlib.so.0 $(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0; \ fi install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \ $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \ $(PREFIX)/bin/nbfind $(PREFIX)/bin/mtrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \ $(PREFIX)/bin/mt-old-to-new.sh $(PREFIX)/bin/mt-new-to-old.sh \ $(PREFIX)/bin/convert-db.sh $(PREFIX)/bin/convert-db.sh \ $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun \ $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/mtutil \ $(PREFIX)/share/db/mt-pg.sql \ $(PREFIX)/share/js/jquery-3.1.0.slim.min.js \ $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so \ $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so.0 \ $(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0 $(PREFIX)/bin/serialize-env # $(PREFIX)/bin/.$(ARCHSTR)/ndboard $(PREFIX)/bin/tcmt # $(PREFIX)/bin/.$(ARCHSTR)/mtexec $(PREFIX)/bin/mtexec $(PREFIX)/bin/serialize-env \ # $(PREFIX)/bin/newdashboard $(PREFIX)/bin/.$(ARCHSTR) : mkdir -p $(PREFIX)/bin/.$(ARCHSTR) mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib test: tests/tests.scm |
︙ | ︙ | |||
443 444 445 446 447 448 449 | else \ echo "(define *use-new-readline* #t)" > readline-fix.scm;\ fi altdb.scm : echo ";; optional alternate db setup" > altdb.scm echo "(define *available-db* (make-hash-table))" >> altdb.scm | | | > > > > > > | | > > > > > > > > > < < < < < < < < | 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 | else \ echo "(define *use-new-readline* #t)" > readline-fix.scm;\ fi altdb.scm : echo ";; optional alternate db setup" > altdb.scm echo "(define *available-db* (make-hash-table))" >> altdb.scm if csi -ne '(use mysql-client)' &> /dev/null;then \ echo "(use mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \ fi if csi -ne '(use postgresql)'&> /dev/null;then \ echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\ fi if csi -ne '(import mysql-client)'&> /dev/null;then \ echo "(import mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \ fi if csi -ne '(import postgresql)'&> /dev/null;then \ echo "(import postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\ fi # portlogger-example : portlogger-example.scm api.o archive.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.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 synchash.o tasks.o tdb.o tests.o tree.o # csc $(CSCOPTS) portlogger-example.scm api.o archive.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.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 sync-hash.o tasks.o tdb.o tests.o tree.o unitdeps.dot : *scm ./utils/plot-uses Makefile ./utils/plot-uses todot commonmod.import,mtargs.import,mtargs,debugprint *.scm > unitdeps.dot unitdeps.pdf : unitdeps.dot dot unitdeps.dot -Tpdf -o unitdeps.pdf ./utils/plot-uses : utils/plot-uses.scm csc utils/plot-uses.scm # create a pdf dot graphviz diagram from notations in rmt.scm rmt.pdf : rmt.scm grep ';;DOT' rmt.scm | sed -e 's/.*;;DOT //' > rmt.dot;dot -Tpdf rmt.dot -o rmt.pdf buildmanual: cd docs/manual && make targets: @grep : Makefile | perl -ne '/^([A-Za-z0-9_-]+):/ && print "$$1\n"' unit : cd tests;make unit |
Modified NOTES from [0b75f67e74] to [7c075bb80d].
︙ | ︙ | |||
10 11 12 13 14 15 16 | # 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/>. | < < < < < | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | # 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/>. ===================================================================== NOTES from looking at branch v1.62-rpc ===================================================================== *last-db-access* or *db-last-access* ==> which is it to be? seen in singletest: ERROR: Unrecognised arguments: :first_err This is the first error |
︙ | ︙ |
Modified TODO from [0885dee1e5] to [497ddac27d].
︙ | ︙ | |||
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/>. TODO ==== | | > > > > > > > | > > > > > | > > > > > > > > | > > > > > | > > > > > > > > > > | > > > > > > | 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 | # # You should have received a copy of the GNU General Public License # along with Megatest. If not, see <http://www.gnu.org/licenses/>. TODO ==== 23WW48 . Add calls-per-minute to db access stats . Find out why start-server calls are taking 250ms and fix . Allow two or three servers to run for any given db . Update avg call count/sec every 30 sec in no-sync . get server uses no-sync process info to decide which server to suggest . Use process table to decide who will do sync back . Fix metadat being synced over and over 23WW47 . Finding server .. look at .servinfo for likely prime main .. ask the .servinfo prime main for real prime main .. save prime main (for how long, 10 seconds or 10 minutes?) . Starting prime main .. get servinfo files - START .. no files? create my servinfo file, goto START .. have files? am I the prime main according to servinfo files? .. no, I'm not the prime main, ping prime main .. ping is good, prime main exists, register self as server if on same host as prime main DONE .. no pirng response, remove the .servinfo file - goto START .. if I am prime main according to .servinfo files, register directly in no-sync . Starting non-main .. get servinfo files .. no files? launch server for main.db .. have files? pick out prime main .. register self as server with prime main 23WW46 - v1.80 branch . Use file semaphore to kill tests, eliminate db load of the KILLREQ query . Merge this change to revolution branch 23WW45 - the revolution branch . Add "fast" db start option (no handshaking over NFS) . Add server-ro to server types (just "server" is fine for read/write). . [DONE] Create pause-server and resume-server calls . Create rsync or cp sync to MTRAH function . Change rmt:send-receive to divert calls to read-only server when possible . [DONE] Change start server to call main.db server for 1..N.db servers, block until server is read for use. 23WW21 . Dashboard needs its own cache db in /tmp 23WW07 . Remove use of *dbstruct-dbs* WW15 . fill newview matrix with data, filter pipeline gui elements . improve [script], especially indent handling WW16 . split db into megatest.db (runs etc.) db/<something>.db . release basic newview implementation WW18 . release split db implementation . mtutil calls from dashboard (for remote control) . logs browser (esp. for surfacing mtutil related activities) WW19 . break command line into sections; all, run control, queries, utilities etc. . pull in ftfplan (not integrated, just code pulled in) WW20 . ./configure => ubuntu, sles11, sles12, rh7 . Jenkins junit XML support . Add output flushing in teamcity support . Switch to using simple runs query everywhere . Add end_time to runs and add a rollup call that sets state, status and end_time Future . Switch to scsh-process pipeline management for job execution/control . Use call-with-environment-variables more. |
︙ | ︙ |
Modified api.scm from [2de2a631a2] to [7f68d2f308].
︙ | ︙ | |||
14 15 16 17 18 19 20 | ;; 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/>. ;; ;;====================================================================== | > | | | | | > > > > > > > > > > > > > > > | | | > | | > | | | 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 | ;; 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 api)) (declare (uses db)) (declare (uses debugprint)) (declare (uses commonmod)) (declare (uses dbmod)) (declare (uses dbfile)) (declare (uses tasks)) (declare (uses tcp-transportmod)) (import commonmod) (import dbmod) (import dbfile) (import debugprint) (import tcp-transportmod) (use srfi-69 srfi-18 posix matchable s11n typed-records) ;; allow these queries through without starting a server ;; (define api:read-only-queries '(get-key-val-pairs get-var get-keys get-key-vals test-toplevel-num-items get-test-info-by-id get-test-state-status-by-id get-steps-info-by-id get-data-info-by-id test-get-rundir-from-test-id get-count-tests-running-for-testname get-count-tests-running get-count-tests-running-in-jobgroup get-previous-test-run-record get-matching-previous-test-run-records test-get-logfile-info test-get-records-for-index-file get-testinfo-state-status test-get-top-process-pid test-get-paths-matching-keynames-target-new get-prereqs-not-met get-count-tests-running-for-run-id get-run-info get-run-status get-run-state get-run-stats get-run-times get-target get-targets ;; register-run get-tests-tags get-test-times get-tests-for-run get-tests-for-run-state-status get-test-id get-tests-for-runs-mindata get-tests-for-run-mindata get-run-name-from-id get-runs simple-get-runs get-num-runs get-runs-cnt-by-patt get-all-run-ids get-prev-run-ids get-run-ids-matching-target get-runs-by-patt get-steps-data get-steps-for-test read-test-data read-test-data-varpatt login tasks-get-last testmeta-get-record have-incompletes? get-changed-record-ids get-all-runids get-changed-record-test-ids get-changed-record-run-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 |
︙ | ︙ | |||
117 118 119 120 121 122 123 | teststep-set-status! delete-steps-for-test ;; TEST DATA test-data-rollup csv->test-data ;; MISC | | > | | > > > | > > > > > | > > > > | | > > > | > > | > > | > > > > | | > > > | < > > > | > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | > > > > > > | < < > | > > | > | | < < < | > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > | > | | | | > > > > > > > > > > > > > > | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | | | | | | | | | | > > | | | | | | | | | | > > | > | | | | | | | | | | | | | | | | | | > > > > > > | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | < | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | > | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 | teststep-set-status! delete-steps-for-test ;; TEST DATA test-data-rollup csv->test-data ;; MISC sync-cachedb->db drop-all-triggers create-all-triggers update-tesdata-on-repilcate-db ;; TESTMETA testmeta-add-record testmeta-update-field ;; TASKS tasks-add tasks-set-state-given-param-key )) (define *db-write-mutexes* (make-hash-table)) (define *server-signature* #f) (define *api-threads* '()) (define (api:register-thread th-in command) (set! *api-threads* (cons (list th-in (current-seconds) command) *api-threads*))) (define (api:get-thread-command th-in) (let ((thread-data (assoc th-in *api-threads*))) (if thread-data (third thread-data) ; Assuming the command is the third element in the list #f))) ; Return #f if the thread is not found (define (api:unregister-thread th-in) (set! *api-threads* (filter (lambda (thdat) (not (eq? th-in (car thdat)))) *api-threads*))) (define (api:remove-dead-or-terminated) (set! *api-threads* (filter (lambda (thdat) (not (member (thread-state (car thdat)) '(terminated dead)))) *api-threads*))) (define (api:get-count-threads-alive) (length *api-threads*)) (define (api:get-threads) (map (lambda (thdat) (let ((thread (first thdat)) (timestamp (second thdat)) (command (third thdat))) (format "\nThread: ~a, age: ~a, Command: ~a" thread (- (current-seconds) timestamp) command))) *api-threads*)) (define *api:last-stats-print* 0) (define *api-print-db-stats-mutex* (make-mutex)) (define (api:print-db-stats) (debug:print-info 0 *default-log-port* "Started periodic db stats printer") (let loop () (mutex-lock! *api-print-db-stats-mutex*) (if (> (- (current-seconds) *api:last-stats-print*) 15) (begin (rmt:print-db-stats) (set! *api:last-stats-print* (current-seconds)))) (mutex-unlock! *api-print-db-stats-mutex*) (thread-sleep! 5) (loop))) ;; indat is (cmd run-id params meta) ;; ;; WARNING: Do not print anything in the lambda of this function as it ;; reads/writes to current in/out port ;; (define (api:tcp-dispatch-request-make-handler dbstruct) ;; cmd run-id params) (assert *toppath* "FATAL: api:tcp-dispatch-request-make-handler called but *toppath* not set.") (if (not *server-signature*) (set! *server-signature* (tt:mk-signature *toppath*))) (lambda (indat) (api:register-thread (current-thread) (car indat)) (let* ((result (let* ((numthreads (api:get-count-threads-alive)) (delay-wait (if (> numthreads 10) (- numthreads 10) 0)) (normal-proc (lambda (cmd run-id params) (case cmd ((ping) *server-signature*) (else (api:dispatch-request dbstruct cmd run-id params)))))) (set! *api-process-request-count* numthreads) (set! *db-last-access* (current-seconds)) ;; (if (not (eq? numthreads numthreads)) ;; (begin ;; (api:remove-dead-or-terminated) ;; (let ((threads-now (api:get-count-threads-alive))) ;; (debug:print 0 *default-log-port* "WARNING: numthreads="numthreads", numthreads="numthreads", remaining="threads-now) ;; (set! numthreads threads-now)))) (match indat ((cmd run-id params meta) (let* ((start-t (current-milliseconds)) (db-ok (let* ((dbfname (dbmod:run-id->dbfname run-id)) (ok (equal? dbfname (dbr:dbstruct-dbfname dbstruct)))) (case cmd ((ping) #t) ;; we are fine (else (assert ok "FATAL: database file and run-id not aligned."))))) (ttdat *server-info*) (server-state (tt-state ttdat)) (maxthreads 20) ;; make this a parameter? (status (cond ((> numthreads maxthreads) (let* ((testsuite (common:get-testsuite-name)) (mtexe (common:find-local-megatest)) (proc (lambda () ;; we are overloaded, try to start another server (debug:print 0 *default-log-port* "Too many threads running, starting another server") (tt:server-process-run *toppath* testsuite mtexe run-id)))) (set! *server-start-requests* (cons proc *server-start-requests*))) ;; 'busy 'loaded ;; not ideal since the client will not backoff ) (else 'ok))) (errmsg (case status ((busy) (conc "Server overloaded, "numthreads" threads in flight, current cmd: " cmd "\n current threads: " (api:get-threads))) ((loaded) (conc "Server loaded, "numthreads" threads in flight")) (else #f))) (result (case status ((busy) (if (eq? cmd 'ping) (normal-proc cmd run-id params) ;; numthreads must be greater than 5 for busy (* 0.1 (- numthreads maxthreads)) ;; was 15 )) ;; (- numthreads 29)) ;; call back in as many seconds ((loaded) ;; (if (eq? (rmt:transport-mode) 'tcp) ;; (thread-sleep! 0.5)) (normal-proc cmd run-id params)) (else (normal-proc cmd run-id params)))) (meta (case cmd ((ping) `((sstate . ,server-state)(sload . ,numthreads))) (else `((wait . ,delay-wait))))) (payload (list status errmsg result meta))) ;; (cmd run-id params meta) (db:add-stats cmd run-id params (- (current-milliseconds) start-t)) payload)) (else (assert #f "FATAL: failed to deserialize indat "indat)))))) ;; (set! *api-process-request-count* (- *api-process-request-count* 1)) ;; (serialize payload) (api:unregister-thread (current-thread)) result))) (define *api-halt-writes* #f) (define (api:dispatch-request dbstruct cmd run-id params) (if (not *no-sync-db*) (db:open-no-sync-db)) (let* ((start-time (current-milliseconds))) (if (member cmd api:write-queries) (let loop () (if *api-halt-writes* (begin (thread-sleep! 0.2) (if (< (- (current-milliseconds) start-time) 5000) ;; hope it don't take more than five seconds to sync (loop-time) #;(debug:print 0 *default-log-port* "ERROR: writes halted for more than 5 seconds, sync might be taking too long")))))) (db:add-stats 'api-write-blocking-for-sync run-id params (- (current-milliseconds) start-time))) (case cmd ;;=============================================== ;; READ/WRITE QUERIES ;;=============================================== ((get-keys-write) (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl ;; SERVERS ((start-server) (apply tt:server-process-run params)) ((kill-server) (set! *server-run* #f)) ;; TESTS ;;((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params)) ;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items. ((test-set-state-status-by-id) ;; (define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment) (db:set-state-status-and-roll-up-items dbstruct (list-ref params 0) ; run-id (list-ref params 1) ; test-name #f ; item-path (list-ref params 2) ; state (list-ref params 3) ; status (list-ref params 4) ; comment )) ((delete-test-records) (apply db:delete-test-records dbstruct params)) ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params)) ((test-set-state-status) (apply db:test-set-state-status dbstruct params)) ((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct params)) ((set-state-status-and-roll-up-items) (apply db:set-state-status-and-roll-up-items dbstruct params)) ((set-state-status-and-roll-up-run) (apply db:set-state-status-and-roll-up-run dbstruct params)) ((top-test-set-per-pf-counts) (apply db:top-test-set-per-pf-counts dbstruct params)) ((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct params)) ((insert-test) (db:insert-test dbstruct run-id params)) ;; RUNS ((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)) ((insert-run) (apply db:insert-run 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-cachedb->db) (let ((run-id (car params))) (db:sync-touched dbstruct run-id db:initialize-main-db force-sync: #t))) ((get-toplevels-and-incompletes) (apply db:get-toplevels-and-incompletes dbstruct params)) ((mark-incomplete) #f);;(thread-start! (make-thread (lambda () ;; no need to block on this one ;; (apply db:find-and-mark-incomplete dbstruct params) ;; #t)))) ((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)) ((no-sync-add-job) (apply db:no-sync-add-job *no-sync-db* params)) ((no-sync-take-job) (apply db:no-sync-take-job *no-sync-db* params)) ((no-sync-job-records-clean) (apply db:no-sync-job-records-clean *no-sync-db* params)) ;; NO SYNC DB PROCESSES ((register-process) (apply dbfile:register-process *no-sync-db* params)) ((set-process-done) (apply dbfile:set-process-done *no-sync-db* params)) ((set-process-status) (apply dbfile:set-process-status *no-sync-db* params)) ((get-process-options) (apply dbfile:get-process-options *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)) ;;====================================================================== ;; READ ONLY QUERIES ;;====================================================================== ;; KEYS ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params)) ((get-keys) (db:get-keys dbstruct)) ((get-key-vals) (apply db:get-key-vals dbstruct params)) ((get-target) (apply db:get-target dbstruct params)) ((get-targets) (db:get-targets dbstruct)) ;; ARCHIVES ((test-get-archive-block-info) (apply db:test-get-archive-block-info dbstruct params)) ;; TESTS ((test-toplevel-num-items) (apply db:test-toplevel-num-items dbstruct params)) ((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct params)) ((get-test-state-status-by-id) (apply db:get-test-state-status-by-id dbstruct params)) ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params)) ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params)) ((get-count-tests-running) (apply db:get-count-tests-running dbstruct params)) ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params)) ;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params)) ;; ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params)) ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params)) ((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params)) ((test-get-records-for-index-file) (apply db:test-get-records-for-index-file dbstruct params)) ((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params)) ((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct params)) ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params)) ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params)) ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params)) ((get-not-completed-cnt) (apply db:get-not-completed-cnt dbstruct params)) ((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params)) ((get-test-times) (apply db:get-test-times dbstruct params)) ;; 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)) ((get-run-state-status) (apply db:get-run-state-status 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)) ((get-num-runs) (apply db:get-num-runs dbstruct params)) ((get-runs-cnt-by-patt) (apply db:get-runs-cnt-by-patt dbstruct params)) ((get-all-run-ids) (db:get-all-run-ids dbstruct)) ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params)) ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params)) ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params)) ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) ((get-main-run-stats) (apply db:get-main-run-stats dbstruct params)) ((get-var) (apply db:get-var dbstruct params)) ((get-run-stats) (apply db:get-run-stats dbstruct params)) ((get-run-times) (apply db:get-run-times dbstruct params)) ;; STEPS ((get-steps-data) (apply db:get-steps-data dbstruct params)) ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) ((get-steps-info-by-id) (apply db:get-steps-info-by-id dbstruct params)) ;; TEST DATA ((read-test-data) (apply db:read-test-data dbstruct params)) ((read-test-data-varpatt) (apply db:read-test-data-varpatt dbstruct params)) ((get-data-info-by-id) (apply db:get-data-info-by-id dbstruct params)) ;; MISC ((get-latest-host-load) (apply db:get-latest-host-load dbstruct params)) ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) ((login) (apply db:login dbstruct params)) ((general-call) (let ((stmtname (car params)) (run-id (cadr params)) (realparams (cddr params))) (db:general-call dbstruct run-id stmtname realparams))) ((sdb-qry) (apply sdb:qry params)) ((ping) (current-process-id)) ((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params)) ((get-changed-record-test-ids) (apply db:get-changed-record-test-ids dbstruct params)) ((get-changed-record-run-ids) (apply db:get-changed-record-run-ids dbstruct params)) ((get-run-record-ids) (apply db:get-run-record-ids dbstruct params)) ((get-all-runids) (apply db:get-all-runids dbstruct)) ;; TESTMETA ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params)) ;; TASKS ((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params)) (else (debug:print 0 *default-log-port* "ERROR: bad api call " cmd) (conc "ERROR: BAD api call " cmd)))) |
Modified apimod.scm from [0c866deee4] to [eede50dabc].
︙ | ︙ | |||
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 apimod)) (declare (uses commonmod)) | < < < < < | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | ;; 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)) (module apimod * (import scheme chicken data-structures extras) (import (prefix sqlite3 sqlite3:) posix typed-records srfi-18) (import commonmod) ) |
Modified archive.scm from [e54df630d3] to [f055a5fe0c].
︙ | ︙ | |||
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/>. ;; ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') | < < > > > > > > > > > > > > | 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 | ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') (declare (unit archive)) (declare (uses db)) (declare (uses debugprint)) (declare (uses mtargs)) (declare (uses common)) (declare (uses commonmod)) (declare (uses rmtmod)) (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18) (import commonmod debugprint rmtmod (prefix mtargs args:)) (include "common_records.scm") (include "db_records.scm") ;;====================================================================== ;; ;;====================================================================== |
︙ | ︙ | |||
344 345 346 347 348 349 350 | (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)) | | | | 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 | (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 (server:choose-server *toppath* 'homehost)) (archive-time (seconds->std-time-str (current-seconds))) (archive-staging-db (conc *toppath* "/.db-snapshot/archive_" archive-time)) (tmp-db-path (conc (dbfile:make-tmpdir-name *toppath* "") "/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")) |
︙ | ︙ | |||
382 383 384 385 386 387 388 | (exit 1)))) (debug:print-info 2 *default-log-port* "Archiving data with bup") (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix))) (if (not (eq? exit-code 0)) (begin (debug:print-error 0 *default-log-port* "There was an error archiving data with bup. Archive failed.") (exit 1)) | | | | > | | < > | 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 | (exit 1)))) (debug:print-info 2 *default-log-port* "Archiving data with bup") (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix))) (if (not (eq? exit-code 0)) (begin (debug:print-error 0 *default-log-port* "There was an error archiving data with bup. Archive failed.") (exit 1)) (debug:print-info 0 *default-log-port* "To restore megatest.db run megatest -archive replicacte-db -source archive-dir -time-stamp <ts>. Current timestamp: " (seconds->std-time-str (current-seconds))))))) (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 2 *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: "Running:")) (sleep 2) (db:multi-db-sync (db:setup) ;; (db:setup-db *dbstruct-dbs* *toppath* #f) 'killservers ;'dejunk ;'adj-testids 'old2new ) (debug:print-info 1 *default-log-port* "dropping triggers 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 '())) (debug:print-info 0 *default-log-port* cmd) (handle-exceptions exn #f ;; anything goes wrong - assume the process in NOT running. (with-input-from-pipe cmd (lambda () (let* ((inl (read-lines))) |
︙ | ︙ | |||
435 436 437 438 439 440 441 | (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 target test-partial-path test-last-update) | | > | | 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 | (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 target test-partial-path test-last-update) (debug:print-info 0 *default-log-port* "Test last update time:" (seconds->std-time-str test-last-update)) (let* ((internal-path (conc testsuite-name "-" target)) (archive-update-delay (string->number (or (configf:lookup *configdat* "archive" "test-update-delay") "900" ))) (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)) archive-update-delay) (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) |
︙ | ︙ | |||
504 505 506 507 508 509 510 511 512 513 514 515 516 517 | (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) | > | 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 | (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 (debug:print-info 0 *default-log-port* "Archive time: " archive-timestamp-dir) (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) |
︙ | ︙ |
Added artifacts.scm version [2d0631d1c4].
> > > > > > > > > > > > > > > > > > > > > > > > | 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 artifacts)) (include "artifacts/artifacts.scm") |
Added artifacts/README version [f734b55b91].
> | 1 | NOTE: keep megatest/artifacts/ in sync with datastore/artifacts |
Added artifacts/artifacts.meta version [9ccf727941].
> > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | ;; -*- scheme -*- ( ; Your egg's license: (license "BSD") ; Pick one from the list of categories (see below) for your egg and enter it ; here. (category db) ; A list of eggs pkts depends on. If none, you can omit this declaration ; altogether. If you are making an egg for chicken 3 and you need to use ; procedures from the `files' unit, be sure to include the `files' egg in the ; `needs' section (chicken versions < 3.4.0 don't provide the `files' unit). ; `depends' is an alias to `needs'. ;; (needs (autoload "3.0")) ; A list of eggs required for TESTING ONLY. See the `Tests' section. (test-depends test) (author "Matt Welland") (synopsis "A sha1-chain based datastore similar to the data format in fossil scm, consisting of artifacts of single line cards.")) |
Added artifacts/artifacts.release-info version [fbbc2937bb].
> > > | 1 2 3 | (repo fossil "http://www.kiatoa.com/cgi-bin/fossils/{egg-name}") (uri zip "http://www.kiatoa.com/cgi-bin/fossils/{egg-name}/zip/{egg-name}.zip?uuid={egg-release}") (release "1.0") |
Added artifacts/artifacts.scm version [b5b4746c14].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;; Copyright 2006-2017, Matthew Welland. ;; ;; This file is part of artifacts ;; ;; Pkts 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. ;; ;; Pkts 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 Pkts. If not, see <http://www.gnu.org/licenses/>. ;; ;; CARDS: ;; ;; A card is a line of text, the first two characters are a letter followed by a ;; space. The letter is the card type. ;; ;; artifact: ;; ;; An artifact is a sorted list of cards with a final card Z that contains the shar1 hash ;; of all of the preceding cards. ;; ;; AARTIFACT: ;; ;; An alist mapping card types to card data ;; '((T . "artifacttype") ;; (a . "some content")) ;; ;; EARTIFACT: ;; ;; Extended packet using friendly keys. Must use a artifactspec to convert to/from eartifacts ;; '((ptype . "artifacttype") ;; (adata . "some content)) ;; ;; DARTIFACT: ;; ;; artifacts pulled from the database have this format: ;; ;;((aartifact (Z . "7de89c09ac024b3832c93e16cd78d11e2e28733b") <= this is a the alist ;; (t . "v1.63/tip/dev") ;; (c . "QUICKPATT") ;; (T . "runstart") ;; (P . "354eeb67120a921e3e33155ecab1b522ac10b6bd") ;; (D . "1488995096.0")) ;; (id . 8) ;; (group-id . 0) ;; (uuid . "7de89c09ac024b3832c93e16cd78d11e2e28733b") ;; (parent . "") ;; (artifact-type . "runstart") ;; (artifact . "D 1488995096.0\nP 354eeb67120a921e3e33155ecab1b522ac10b6bd\nT runstart\nc QUICKPATT\nt v1.63/tip/dev\nZ 7de89c09ac024b3832c93e16cd78d11e2e28733b")) ;; ;; artifactspec is alist of alists mapping types and nicekeys to keys ;; ;; '((posting . ((title . t) ;; (url . u) ;; (blurb . b))) ;; (comment . ((comment . c) ;; (score . s)))) ;; Reserved cards: ;; P : artifact parent ;; R : reference artifact containing mapping of short string -> sha1sum strings ;; T : artifact type ;; D : current time from (current-time), unless provided ;; Z : shar1 hash of the packet ;; Example usage: ;; ;; Create a artifact: ;; ;; (use artifacts) ;; (define-values (uuid artifact) ;; (alist->artifact ;; '((fruit . "apple") (meat . "beef")) ;; this is the data to convert ;; '((foods (fruit . f) (meat . m))) ;; this is the artifact spec ;; ptype: ;; 'foods)) ;; ;; Add to artifact queue: ;; ;; (define db (open-queue-db "/tmp/artifacts" "artifacts.db")) ;; (add-to-queue db artifact uuid 'foods #f 0) ;; no parent and use group_id of 0 ;; ;; Retrieve the packet from the db and extract a value: ;; ;; (alist-ref ;; 'meat ;; (dartifact->alist ;; (car (get-dartifacts db #f 0 #f)) ;; '((foods (fruit . f) ;; (meat . m))))) ;; => "beef" ;; (module artifacts ( ;; cards, util and misc ;; sort-cards ;; calc-sha1 ;; ;; low-level constructor procs, exposed only for development/testing, will be removed construct-sdat construct-artifact card->type/value add-z-card ;; queue database procs open-queue-db add-to-queue create-and-queue ;; lookup-by-uuid lookup-by-id get-dartifacts get-not-processed-artifacts get-related find-artifacts process-artifacts get-descendents get-ancestors get-artifacts ;; get-last-descendent ;; with-queue-db ;; load-artifacts-to-db ;; procs that operate directly on artifacts, sdat, aartifacts, dartifacts etc. artifact->alist ;; artifact -> aartifact (i.e. alist) artifact->sdat ;; artifact -> '("a aval" "b bval" ...) sdat->alist ;; '("a aval" "b bval"...) -> ((a . "aval")(b . "bval") ...) dblst->dartifacts ;; convert list of tuples from queue db into dartifacts dartifact->alist ;; flatten a dartifact into an alist containing all db fields and the artifact alist dartifacts->alists ;; apply dartifact->alist to a list of alists using a artifact-spec alist->artifact ;; returns two values uuid, artifact get-value ;; looks up a value given a key in a dartifact flatten-all ;; merge the list of values from a query which includes a artifact into a flat alist <== really useful! check-artifact ;; artifact alists write-alist->artifact read-artifact->alist ;; archive database ;; archive-open-db ;; write-archive-artifacts ;; archive-artifacts ;; mark-processed ;; artifactsdb artifactdb-conn ;; useful artifactdb-fname artifactsdb-open artifactsdb-close artifactsdb-add-record ;; temporary artifactdb-artifactspec ;; utility procs increment-string ;; used to get indexes for strings in ref artifacts make-report ;; make a .dot file calc-sha1 uuid-first-two-letters uuid-remaining-letters ;; file and directory utils multi-glob capture-dir file-get-sha1 check-same link-or-copy same-partition? link-if-same-partition archive-copy write-to-archive artifact-rollup read-artifacts-into-hash hash-of-artifacts->bundle archive-dest ;; pathname-full-filename ;; minimal artifact functions minimal-artifact-read minimal-artifact->alist afact-get-D afact-get-Z afact-get-T afact-get afact-get-number/default ;; bundles write-bundle read-bundle ;; new artifacts db with-todays-adb get-all-artifacts refresh-artifacts-db ) (import (chicken base) scheme (chicken process) (chicken time posix) (chicken io) (chicken file) (chicken pathname) chicken.process-context.posix (chicken string) (chicken time) (chicken sort) (chicken file posix) (chicken condition) srfi-1 regex srfi-13 srfi-69 (chicken port) (chicken process-context) crypt sha1 matchable message-digest sqlite3 typed-records directory-utils scsh-process) ;;====================================================================== ;; DATA MANIPULATION UTILS ;;====================================================================== (define-inline (unescape-data data) (string-translate* data '(("\\n" . "\n") ("\\\\" . "\\")))) (define-inline (escape-data data) (string-translate* data '(("\n" . "\\n") ("\\" . "\\\\")))) (define-inline (make-card type data) (conc type " " (escape-data (->string data)))) ;; reverse an alist for doing artifactkey -> external key conversions ;; (define-inline (reverse-aspec aspec) (map (lambda (dat) (cons (cdr dat)(car dat))) aspec)) ;; add a card to the list of cards, sdat ;; if type is #f return only sdat ;; if data is #f return only sdat ;; (define-inline (add-card sdat type data) (if (and type data) (cons (make-card type data) sdat) sdat)) ;;====================================================================== ;; STRING AS FUNKY NUMBER ;;====================================================================== ;; NOTE: PTDZ are removed as they are reserved. NB// the R card is not used in a ;; ref, instead the P parent card is used. ;; Question: Why does it matter to remove PTDZ? ;; To make the ref easier to use the ref strings will be the keys ;; so we cannot have overlap with any actual keys. But this is a ;; bit silly. What we need to do instead is reject keys of length ;; one where the char is in PTDZ ;; ;; This is basically base92 ;; (define string-num-chars (string->list "!#$%&'()*+,-./0123456789:;<=>?@ABCEFGHIJKLMNOQRSUVWXY[\\]^_abcdefghijklmnopqrstuvwxyz{|}~")) ;; "0123456789abcdefghijklmnopqrstuvwxyzABCEFGHIJKLMNOQSUVWXY!#$%&'()*+,-./[]:;<=>?\\^_{}|")) (define (char-incr inchar) (let* ((carry #f) (next-char (let ((rem (member inchar string-num-chars))) (if (eq? (length rem) 1) ;; we are at the last character in our string-num-chars list (begin (set! carry #t) (car string-num-chars)) (cadr rem))))) (values next-char carry))) (define (increment-string str) (if (string-null? str) "0" (let ((strlst (reverse (string->list str)))) ;; need to process the string from the lsd (list->string (let loop ((hed (car strlst)) (tal (cdr strlst)) (res '())) (let-values (((newhed carry)(char-incr hed))) ;; (print "newhed: " newhed " carry: " carry " tal: " tal) (let ((newres (cons newhed res))) (if carry ;; we'll have to propagate the carry (if (null? tal) ;; at the end, tack on "0" (which is really a "1") (cons (car string-num-chars) newres) (loop (car tal)(cdr tal) newres)) (append (reverse tal) newres))))))))) ;;====================================================================== ;; P K T S D B I N T E R F A C E ;; ;; INTEGER, REAL, TEXT ;;====================================================================== ;; ;; spec ;; ( (tablename1 . (field1name L1 TYPE) ;; (field2name L2 TYPE) ... ) ;; (tablename2 ... )) ;; ;; Example: (tests (testname n TEXT) ;; (rundir r TEXT) ;; ... ) ;; ;; artifact keys are taken from the first letter, if that is not unique ;; then look at the next letter and so on ;; ;; simplify frequent need to get one result with default ;; (define (get-one db default qry . params) (apply fold-row car default db qry params)) (define (get-rows db qry . params) (apply fold-row cons db qry params)) ;; use this struct to hold the artifactspec and the db handle ;; (defstruct artifactdb (fname #f) (artifactsdb-spec #f) (artifactspec #f) ;; cache the artifactspec (field-keys #f) ;; cache the field->key mapping (field1 . k1) ... (key-fields #f) ;; cache the key->field mapping (conn #f) ) ;; WARNING: There is a simplification in the artifactsdb spec w.r.t. artifactspec. ;; The field specs are the cdr of the table list - not a full ;; list. The extra list level in artifactspec is gratuitous and should ;; be removed. ;; (define (artifactsdb-spec->artifactspec tables-spec) (map (lambda (tablespec) (list (car tablespec) (map (lambda (field-spec) (cons (car field-spec)(cadr field-spec))) (cdr tablespec)))) tables-spec)) (define (artifactsdb-open dbfname artifactsdb-spec) (let* ((pdb (make-artifactdb)) (dbexists (file-exists? dbfname)) (db (open-database dbfname))) (artifactdb-artifactsdb-spec-set! pdb artifactsdb-spec) (artifactdb-artifactspec-set! pdb (artifactsdb-spec->artifactspec artifactsdb-spec)) (artifactdb-fname-set! pdb dbfname) (artifactdb-conn-set! pdb db) (if (not dbexists) (artifactsdb-init pdb)) pdb)) (define (artifactsdb-init artifactsdb) (let* ((db (artifactdb-conn artifactsdb)) (artifactsdb-spec (artifactdb-artifactsdb-spec artifactsdb))) ;; create a table for the artifacts themselves (execute db "CREATE TABLE IF NOT EXISTS artifacts (id INTEGER PRIMARY KEY, zkey TEXT, record_id INTEGER, artifact TEXT);") (for-each (lambda (table) (let* ((table-name (car table)) (fields (cdr table)) (stmt (conc "CREATE TABLE IF NOT EXISTS " table-name " (id INTEGER PRIMARY KEY," (string-intersperse (map (lambda (fieldspec) (conc (car fieldspec) " " (caddr fieldspec))) fields) ",") ");"))) (execute db stmt))) artifactsdb-spec))) ;; create artifact from the data and insert into artifacts table ;; ;; data is assoc list of (field . value) ... ;; tablename is a symbol matching the table name ;; (define (artifactsdb-add-record artifactsdb tablename data #!optional (parent #f)) (let*-values (((zkey artifact) (alist->artifact data (artifactdb-artifactspec artifactsdb) ptype: tablename))) ;; have the data as alist so insert it into appropriate table also (let* ((db (artifactdb-conn artifactsdb))) ;; TODO: Address collisions (execute db "INSERT INTO artifacts (zkey,artifact,record_id) VALUES (?,?,?);" zkey artifact -1) (let* (;; (artifactid (artifactsdb-artifactkey->artifactid artifactsdb artifactkey)) (record-id (artifactsdb-insert artifactsdb tablename data))) (execute db "UPDATE artifacts SET record_id=? WHERE zkey=?;" record-id zkey) )))) ;; (define (artifactsdb-insert artifactsdb tablename data) (let* ((db (artifactdb-conn artifactsdb)) (stmt (conc "INSERT INTO " tablename " (" (string-intersperse (map conc (map car data)) ",") ") VALUES ('" ;; TODO: Add lookup of data type and do not ;; wrap integers with quotes (string-intersperse (map conc (map cdr data)) "','") "');"))) (print "stmt: " stmt) (execute db stmt) ;; lookup the record-id and return it )) (define (artifactsdb-close artifactsdb) (finalize! (artifactdb-conn artifactsdb))) ;; (let loop ((s "0")(n 0))(print s)(if (< n 5000)(loop (increment-string s)(+ n 1)))) ;;====================================================================== ;; CARDS, MISC and UTIL ;;====================================================================== ;; given string (likely multi-line) "dat" return shar1 hash ;; (define (calc-sha1 instr) (message-digest-string (sha1-primitive) instr)) ;; given a single card return its type and value ;; (define (card->type/value card) (let ((ctype (substring card 0 1)) (cval (substring card 2 (string-length card)))) (values (string->symbol ctype) cval))) ;;====================================================================== ;; SDAT procs ;; sdat is legacy/internal usage. Intention is to remove sdat calls from ;; the exposed calls. ;;====================================================================== ;; sort list of cards ;; (define-inline (sort-cards sdat) (sort sdat string<=?)) ;; artifact rules ;; 1. one card per line ;; 2. at least one card ;; 3. no blank lines ;; given sdat, a list of cards return uuid, packet (as sdat) ;; (define (add-z-card sdat) (let* ((sorted-sdat (sort-cards sdat)) (dat (string-intersperse sorted-sdat "\n")) (uuid (calc-sha1 dat))) (values uuid (conc dat "\nZ " uuid)))) (define (check-artifact artifact) (handle-exceptions exn #f ;; anything goes wrong - call it a crappy artifact (let* ((sdat (string-split artifact "\n")) (rdat (reverse sdat)) ;; reversed (zdat (car rdat)) (Z (cadr (string-split zdat))) (cdat (string-intersperse (reverse (cdr rdat)) "\n"))) (equal? Z (calc-sha1 cdat))))) ;;====================================================================== ;; AARTIFACTs ;;====================================================================== ;; convert a sdat (list of cards) to an alist ;; (define (sdat->alist sdat) (let loop ((hed (car sdat)) (tal (cdr sdat)) (res '())) (let-values (( (ctype cval)(card->type/value hed) )) ;; if this card is not one of the common ones tack it on to rem (let* ((oldval (alist-ref ctype res)) (newres (cons (cons ctype (if oldval ;; list or string (if (list? oldval) (cons cval oldval) (cons cval (list oldval))) cval)) res))) (if (null? tal) newres (loop (car tal)(cdr tal) newres)))))) ;;((aartifact (Z . "7de89c09ac024b3832c93e16cd78d11e2e28733b") <= this is a the alist ;; (t . "v1.63/tip/dev") ;; (c . "QUICKPATT") ;; (T . "runstart") ;; (P . "354eeb67120a921e3e33155ecab1b522ac10b6bd") ;; (D . "1488995096.0")) ;; (id . 8) ;; (group-id . 0) ;; (uuid . "7de89c09ac024b3832c93e16cd78d11e2e28733b") ;; (parent . "") ;; (artifact-type . "runstart") ;; (artifact . "D 1488995096.0\nP 354eeb67120a921e3e33155ecab1b522ac10b6bd\nT runstart\nc QUICKPATT\nt v1.63/tip/dev\nZ 7de89c09ac024b3832c93e16cd78d11e2e28733b")) ;; ;; artifactspec is alist of alists mapping types and nicekeys to keys ;; ;; '((posting . ((title . t) ;; (url . u) ;; (blurb . b))) ;; (comment . ((comment . c) ;; (score . s)))) ;; DON'T USE? ;; (define (get-value field dartifact . spec-in) (if (null? spec-in) (alist-ref field dartifact) (let* ((spec (car spec-in)) (aartifact (alist-ref 'aartifact dartifact))) ;; get the artifact alist (if (and aartifact spec) (let* ((ptype (alist-ref 'artifact-type dartifact)) (pspec (alist-ref (string->symbol ptype) spec))) ;; do we have a spec for this type of artifact (and pspec (let* ((key (alist-ref field pspec))) (and key (alist-ref key aartifact))))) #f)))) ;; convert a dartifact to a pure alist given a artifactspec ;; this flattens out the alist to include the data from ;; the queue database record ;; (define (dartifact->alist dartifact artifactspec) (let* ((aartifact (alist-ref 'aartifact dartifact)) (artifact-type (or (alist-ref 'artifact-type dartifact) ;; artifact-type is from the database field artifact_type (alist-ref 'T aartifact))) (artifact-fields (alist-ref (string->symbol artifact-type) artifactspec)) (rev-fields (if artifact-fields (reverse-aspec artifact-fields) '()))) (append (map (lambda (entry) (let* ((artifact-key (car entry)) (new-key (or (alist-ref artifact-key rev-fields) artifact-key))) `(,new-key . ,(cdr entry)))) aartifact) dartifact))) ;; convert a list of dartifacts into a list of alists using artifact-spec ;; (define (dartifacts->alists dartifacts artifact-spec) (map (lambda (x) (dartifact->alist x artifact-spec)) dartifacts)) ;; Generic flattener, make the tuple and artifact into a single flat alist ;; ;; qry-result-spec is a list of symbols corresponding to each field ;; (define (flatten-all inlst artifactspec . qry-result-spec) (map (lambda (tuple) (dartifact->alist (apply dblst->dartifacts tuple qry-result-spec) artifactspec)) inlst)) ;; call like this: ;; (construct-sdat 'a "a data" 'S "S data" ...) ;; returns list of cards ;; ( "A a value" "D 12345678900" ...) ;; (define (construct-sdat . alldat) (let ((have-D-card #f)) ;; flag (if (even? (length alldat)) (let loop ((type (car alldat)) (data (cadr alldat)) (tail (cddr alldat)) (res '())) (if (eq? type 'D)(set! have-D-card #t)) (if (null? tail) (if have-D-card ;; return the constructed artifact, add a D card if none found (add-card res type data) (add-card (add-card res 'D (current-seconds)) type data)) (loop (car tail) (cadr tail) (cddr tail) (add-card res type data)))) #f))) ;; #f means it failed to create the sdat (define (construct-artifact . alldat) (add-z-card (apply construct-sdat alldat))) ;;====================================================================== ;; CONVERTERS ;;====================================================================== (define (artifact->sdat artifact) (map unescape-data (string-split artifact "\n"))) ;; given a pure artifact return an alist ;; (define (artifact->alist artifact #!key (artifactspec #f)) (let ((sdat (cond ((string? artifact) (artifact->sdat artifact)) ((list? artifact) artifact) (else #f)))) (if artifact (if artifactspec (dartifact->alist (list (cons 'aartifact (sdat->alist sdat))) artifactspec) (sdat->alist sdat)) #f))) ;; convert an alist to an sdat ;; in: '((a . "blah")(b . "foo")) ;; out: '("a blah" "b foo") ;; (define (alist->sdat adat) (map (lambda (dat) (conc (car dat) " " (cdr dat))) adat)) ;; adat is the incoming alist, aspec is the mapping ;; from incoming key to the artifact key (usually one ;; letter to keep data tight) see the artifactspec at the ;; top of this file ;; ;; NOTE: alists can contain multiple instances of the same key (supported fine by artifacts) ;; but you (obviously I suppose) cannot use alist-ref to access those entries. ;; (define (alist->artifact adat aspec #!key (ptype #f)(no-d #f)) (let* ((artifact-type (or ptype (alist-ref 'T adat) ;; can provide in the incoming alist #f)) (artifact-spec (if artifact-type ;; alist of external-key -> key (or (alist-ref artifact-type aspec) '()) (if (null? aspec) '() (cdar aspec)))) ;; default to first one if nothing specified (new-alist (map (lambda (dat) (let* ((key (car dat)) (val (cdr dat)) (newkey (or (alist-ref key artifact-spec) key))) (cons newkey (escape-data (conc val))))) ;; convert all incoming data (symbols, numbers etc.) to a string and then escape newlines. adat)) (new-with-type (if (alist-ref 'T new-alist) new-alist (cons `(T . ,artifact-type) new-alist))) (with-d-card (if (or no-d ;; no timestamp wanted (alist-ref 'D new-with-type)) new-with-type (cons `(D . ,(current-seconds)) new-with-type)))) (add-z-card (alist->sdat with-d-card)))) ;;====================================================================== ;; D B Q U E U E I N T E R F A C E ;;====================================================================== ;; artifacts ( ;; id SERIAL PRIMARY KEY, ;; uuid TEXT NOT NULL, ;; parent_uuid TEXT default '', ;; artifact_type INTEGER DEFAULT 0, ;; group_id INTEGER NOT NULL, ;; artifact TEXT NOT NULL ;; 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 (open-database 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) (execute db stmt)) (cons "CREATE TABLE IF NOT EXISTS artifacts (id INTEGER PRIMARY KEY, group_id INTEGER NOT NULL, uuid TEXT NOT NULL, parent_uuid TEXT TEXT DEFAULT '', artifact_type TEXT NOT NULL, artifact TEXT NOT NULL, processed INTEGER DEFAULT 0)" schema))) ;; 0=not processed, 1=processed, 2... for expansion db)) (define (add-to-queue db artifact uuid artifact-type parent-uuid group-id) (execute db "INSERT INTO artifacts (uuid,parent_uuid,artifact_type,artifact,group_id) VALUES(?,?,?,?,?);" ;; $1,$2,$3,$4,$5);" uuid (if parent-uuid parent-uuid "");; use null string as placeholder for no parent uuid. (if artifact-type (conc artifact-type) "") artifact group-id)) ;; given all needed parameters create a artifact and store it in the queue ;; procs is an alist that maps artifact-type to a function that takes a list of artifact params ;; in data and returns the uuid and artifact ;; (define (create-and-queue conn procs artifact-type parent-uuid group-id data) (let ((proc (alist-ref artifact-type procs))) (if proc (let-values (( (uuid artifact) (proc data) )) (add-to-queue conn artifact uuid artifact-type parent-uuid group-id) uuid) #f))) ;; given uuid get artifact, if group-id is specified use it (reduces probablity of ;; being messed up by a uuid collision) ;; (define (lookup-by-uuid db artifact-uuid group-id) (if group-id (get-one db "SELECT artifact FROM artifacts WHERE group_id=? AND uuid=?;" group-id artifact-uuid) (get-one db "SELECT artifact FROM artifacts WHERE uuid=?;" artifact-uuid))) ;; find a packet by its id ;; (define (lookup-by-id db id) (get-one db "SELECT artifact FROM artifacts WHERE id=?;" id)) ;;====================================================================== ;; P R O C E S S P K T S ;;====================================================================== ;; given a list of field values pulled from the queue db generate a list ;; of dartifact's ;; (define (dblst->dartifacts lst . altmap) (let* ((maplst (if (null? altmap) '(id group-id uuid parent artifact-type artifact processed) altmap)) (res (map cons maplst lst))) ;; produces list of pairs, i.e an alist (cons `(aartifact . ,(artifact->alist (alist-ref 'artifact res))) res))) ;; NB// ptypes is a list of symbols, '() or #f find all types ;; (define (get-dartifacts db ptypes group-id parent-uuid #!key (uuid #f)) (let* ((ptype-qry (if (and ptypes (not (null? ptypes))) (conc " IN ('" (string-intersperse (map conc ptypes) "','") "')") (conc " LIKE '%' "))) (rows (get-rows db (conc "SELECT id,group_id,uuid,parent_uuid,artifact_type,artifact,processed FROM artifacts WHERE artifact_type " ptype-qry " AND group_id=? AND processed=0 " (if parent-uuid (conc "AND parent_uuid='" parent-uuid "' ") "") (if uuid (conc "AND uuid='" uuid "' ") "") "ORDER BY id DESC;") group-id))) (map dblst->dartifacts (map vector->list rows)))) ;; get N artifacts not yet processed for group-id ;; (define (get-not-processed-artifacts db group-id artifact-type limit offset) (map dblst->dartifacts (map vector->list (get-rows db "SELECT id,group_id,uuid,parent_uuid,artifact_type,artifact,processed FROM artifacts WHERE artifact_type = ? AND group_id = ? AND processed=0 LIMIT ? OFFSET ?;" (conc artifact-type) ;; convert symbols to string group-id limit offset )))) ;; given a uuid, get not processed child artifacts ;; (define (get-related db group-id uuid) (map dblst->dartifacts (get-rows db "SELECT id,group_id,uuid,parent_uuid,artifact_type,artifact,processed FROM artifacts WHERE parent_uuid=? AND group_id=? AND processed=0;" uuid group-id))) ;; generic artifact processor ;; ;; find all packets in group-id of type in ptypes and apply proc to artifactdat ;; (define (process-artifacts conn group-id ptypes parent-uuid proc) (let* ((artifacts (get-dartifacts conn ptypes group-id parent-uuid))) (map proc artifacts))) ;; criteria is an alist ((k . valpatt) ...) ;; - valpatt is a regex ;; - ptypes is a list of types (symbols expected) ;; match-type: 'any or 'all ;; (define (find-artifacts db ptypes criteria #!key (processed #f)(match-type 'any)(artifact-spec #f)) ;; processed=#f, don't use, else use (let* ((artifacts (get-dartifacts db ptypes 0 #f)) (match-rules (lambda (artifactdat) ;; returns a list of matching rules (filter (lambda (c) ;; (print "c: " c) (let* ((ctype (car c)) ;; card type (rx (cdr c)) ;; card pattern ;; (t (alist-ref 'artifact-type artifactdat)) (artifact (alist-ref 'artifact artifactdat)) (aartifact (artifact->alist artifact)) (cdat (alist-ref ctype aartifact))) ;; (print "cdat: " cdat) ;; " aartifact: " aartifact) (if cdat (string-match rx cdat) #f))) criteria))) (res (filter (lambda (artifactdat) (if (null? criteria) ;; looking for all artifacts #t (case match-type ((any)(not (null? (match-rules artifactdat)))) ((all)(eq? (length (match-rules artifactdat))(length criteria))) (else (print "ERROR: bad match type " match-type ", expecting any or all."))))) artifacts))) (if artifact-spec (dartifacts->alists res artifact-spec) res))) ;; get descendents of parent-uuid ;; ;; NOTE: Should be doing something like the following: ;; ;; given a uuid, get not processed child artifacts ;; processed: ;; #f => get all ;; 0 => get not processed ;; 1 => get processed ;; (define (get-ancestors db group-id uuid #!key (processed #f)) (map dblst->dartifacts (map vector->list (get-rows db (conc "SELECT id,group_id,uuid,parent_uuid,artifact_type,artifact,processed FROM artifacts WHERE uuid IN (WITH RECURSIVE tree(uuid,parent_uuid) AS ( SELECT uuid, parent_uuid FROM artifacts WHERE uuid = ? UNION ALL SELECT t.uuid, t.parent_uuid FROM artifacts t JOIN tree ON t.uuid = tree.parent_uuid ) SELECT uuid FROM tree) AND group_id=?" (if processed (conc " AND processed=" processed) "") ";") uuid group-id)))) ;; Untested ;; (define (get-descendents db group-id uuid #!key (processed #f)) (map dblst->dartifacts (map vector->list (get-rows db (conc "SELECT id,group_id,uuid,parent_uuid,artifact_type,artifact,processed FROM artifacts WHERE uuid IN (WITH RECURSIVE tree(uuid,parent_uuid) AS ( SELECT uuid, parent_uuid FROM artifacts WHERE uuid = ? UNION ALL SELECT t.uuid, t.parent_uuid FROM artifacts t JOIN tree ON t.parent_uuid = tree.uuid ) SELECT uuid FROM tree) AND group_id=?" (if processed (conc " AND processed=" processed) "") ";") uuid group-id)))) ;; look up descendents based on given info unless passed in a list via inlst ;; ;; (define (get-last-descendent db group-id uuid #!key (processed #f)(inlst #f)) ;; (let ((descendents (or inlst (get-descendents db group-id uuid processed: processed)))) ;; (if (null? descendents) ;; #f ;; (last descendents)))) ;;====================================================================== ;; A R C H I V E S - always to a sqlite3 db ;;====================================================================== ;; open an archive db ;; path: archive-dir/<year>/month.db ;; #;(define (archive-open-db archive-dir) (let* ((curr-time (seconds->local-time (current-seconds))) (dbpath (conc archive-dir "/" (time->string curr-time "%Y"))) (dbfile (conc dbpath "/" (time->string curr-time "%m") ".db")) (dbexists (if (file-exists? dbfile) #t (begin (create-directory dbpath #t) #f)))) (let ((db (open-database dbfile))) ;; (set-busy-handler! db (busy-timeout 10000)) (if (not dbexists) ;; NOTE: In the archive we allow duplicates and other messiness. (execute db "CREATE TABLE IF NOT EXISTS artifacts (id INTEGER, group_id INTEGER, uuid TEXT, parent_uuid TEXT, artifact_type TEXT, artifact TEXT, processed INTEGER DEFAULT 0)")) db))) ;; turn on transactions! otherwise this will be painfully slow ;; #;(define (write-archive-artifacts src-db db artifact-ids) (let ((artifacts (get-rows src-db (conc "SELECT id,group_id,uuid,parent_uuid,artifact_type,artifact FROM artifacts WHERE id IN (" (string-intersperse (map conc artifact-ids) ",") ")")))) ;; (dbi:with-transaction ;; db (lambda () (for-each (lambda (artifact) (apply execute db "INSERT INTO artifacts (id,group_id,uuid,parent_uuid,artifact_type,artifact) VALUES (?,?,?,?,?,?)" artifact)) artifacts)))) ;; ) ;; given a list of uuids and lists of uuids move all to ;; the sqlite3 db for the current archive period ;; #;(define (archive-artifacts conn artifact-ids archive-dir) (let ((db (archive-open-db archive-dir))) (write-archive-artifacts conn db artifact-ids) (finalize! db)) ;; (pg:with-transaction ;; conn ;; (lambda () (for-each (lambda (id) (get-one conn "DELETE FROM artifacts WHERE id=?" id)) artifact-ids)) ;; )) ;; given a list of ids mark all as processed ;; (define (mark-processed conn artifact-ids) ;; (pg:with-transaction ;; conn ;; (lambda () (for-each (lambda (id) (get-one conn "UPDATE artifacts SET processed=1 WHERE id=?;" id)) artifact-ids)) ;; x)) ;; a generic artifact getter, gets from the artifacts db ;; (define (get-artifacts conn ptypes) (let* ((ptypes-str (if (null? ptypes) "" (conc " WHERE artifact_type IN ('" (string-intersperse ptypes ",") "') "))) (qry-str (conc "SELECT id,group_id,uuid,parent_uuid,artifact_type,artifact,processed FROM artifacts" ptypes-str))) (map vector->list (get-rows conn qry-str)))) ;; make a report of the artifacts in the db ;; ptypes of '() gets all artifacts ;; display-fields ;; (define (make-report dest conn artifactspec display-fields . ptypes) (let* (;; (conn (dbi:db-conn (s:db))) (all-rows (get-artifacts conn ptypes)) (all-artifacts (flatten-all all-rows artifactspec 'id 'group-id 'uuid 'parent 'artifact-type 'artifact 'processed)) (by-uuid (let ((ht (make-hash-table))) (for-each (lambda (artifact) (let ((uuid (alist-ref 'uuid artifact))) (hash-table-set! ht uuid artifact))) all-artifacts) ht)) (by-parent (let ((ht (make-hash-table))) (for-each (lambda (artifact) (let ((parent (alist-ref 'parent artifact))) (hash-table-set! ht parent (cons artifact (hash-table-ref/default ht parent '()))))) all-artifacts) ht)) (oup (if dest (open-output-file dest) (current-output-port)))) (with-output-to-port oup (lambda () (print "digraph megatest_state_status { // ranksep=0.05 rankdir=LR; node [shape=\"box\"]; ") ;; first all the names (for-each (lambda (artifact) (let* ((uuid (alist-ref 'uuid artifact)) (shortuuid (substring uuid 0 4)) (type (alist-ref 'artifact-type artifact)) (processed (alist-ref 'processed artifact))) (print "\"" uuid "\" [label=\"" shortuuid ", (" type ", " (if processed "processed" "not processed") ")") (for-each (lambda (key-field) (let ((val (alist-ref key-field artifact))) (if val (print key-field "=" val)))) display-fields) (print "\" ];"))) all-artifacts) ;; now for parent-child relationships (for-each (lambda (artifact) (let ((uuid (alist-ref 'uuid artifact)) (parent (alist-ref 'parent artifact))) (if (not (equal? parent "")) (print "\"" parent "\" -> \"" uuid"\";")))) all-artifacts) (print "}") )) (if dest (begin (close-output-port oup) (system "dot -Tpdf out.dot -o out.pdf"))) )) ;;====================================================================== ;; Read ref artifacts into a vector < laststr hash table > ;;====================================================================== ;;====================================================================== ;; Read/write packets to files (convience functions) ;;====================================================================== ;; write alist to a artifact file ;; (define (write-alist->artifact targdir dat #!key (artifactspec '())(ptype #f)) (let-values (((uuid artifact)(alist->artifact dat artifactspec ptype: ptype))) (with-output-to-file (conc targdir "/" uuid ".artifact") (lambda () (print artifact))) uuid)) ;; return the uuid ;; read artifact into alist ;; (define (read-artifact->alist artifact-file #!key (artifactspec #f)) (artifact->alist (with-input-from-file artifact-file read-string) artifactspec: artifactspec)) ;;====================================================================== ;; File utils, stuff useful for file management ;;====================================================================== (define (file-get-sha1 fname) (let* ((sha1-res (run/strings (sha1sum ,fname)))) (car (string-split (car sha1-res))))) (define (link-or-copy srcf destf) (or (handle-exceptions exn #f (file-link srcf destf)) (if (file-exists? destf) (print "NOTE: destination already exists, skipping copy.") (copy-file srcf destf)))) ;; (define (files-diff file1 file2) ;; (let* ((diff-res (with-input-from-port ;; (run/port (diff "-q" ,file1 ,file2)) ;; (lambda () ;; (let* ((res (read-line))) ;; (read-lines) ;; res))))) ;; (car (string-split sha1-res)))) ;; (define (check-same file1 file2) (cond ((not (and (file-exists? file1)(file-exists? file2))) #f) ((not (equal? (file-size file1)(file-size file2))) #f) (else (let-values (((status run-ok process-id) (run (diff "-q" ,file1 ,file2)))) status)))) (define *pcache* (make-hash-table)) (define (get-device dir) (let ((indat (or (hash-table-ref/default *pcache* dir #f) (let* ((inp (open-input-pipe (conc "df --output=source \""dir"\""))) (res (read-lines inp))) (close-input-port inp) (hash-table-set! *pcache* dir res) res)))) (cadr indat))) (define (same-partition? dir1 dir2) (equal? (get-device dir1)(get-device dir2))) (define (link-if-same-partition file1 file2) (let* ((dir1 (pathname-directory file1)) (dir2 (pathname-directory file2)) (f1 (pathname-file file1)) (f2 (pathname-file file2))) (if (same-partition? dir1 dir2) (let* ((tmpname (conc "."f2"-"(current-seconds)))) ;; this steps needs to be executed as actual user (move-file file2 (conc dir1 "/" tmpname)) (file-link file1 file2) (delete-file (conc dir1 "/" tmpname)))))) (define (uuid-first-two-letters sha1sum) (substring sha1sum 0 2)) (define (uuid-remaining-letters sha1sum) (let ((slen (string-length sha1sum))) (substring sha1sum 2 slen))) (define (archive-dest destd sha1sum) (let* ((subdir (uuid-first-two-letters sha1sum)) ;; (substring sha1sum 0 2)) ;; (slen (string-length sha1sum)) (rem sha1sum #;(uuid-remaining-letters sha1sum)) ;; (substring sha1sum 3 slen)) (full-dest-dir (conc destd"/"subdir)) (full-dest-file (conc full-dest-dir"/"rem))) (if (not (directory-exists? full-dest-dir)) (create-directory full-dest-dir #t)) full-dest-file)) (define (write-to-archive data destd #!optional (nextnum #f)) (let* ((sha1sum (calc-sha1 data)) (full-dest (conc (archive-dest destd sha1sum) (if nextnum (conc "."nextnum) "")))) (if (file-exists? full-dest) (if (equal? (string-intersperse (with-input-from-file full-dest read-lines) "\n") data) (begin ;; (print "INFO: data already exists in "full-dest" and is identical") sha1sum) (let ((nextnum (if nextnum (+ nextnum 1) 0))) (print "WARN: data already exists in "full-dest" but is different! Trying again...") (write-to-archive data destd nextnum))) (begin (with-output-to-file full-dest (lambda () (print data))) sha1sum)))) ;; BUG? Does print munge data? ;; copy srcf with sha1sum aabc... to aa/bc... ;; (define (archive-copy srcf destd sha1sum) (let* ((full-dest-file (archive-dest destd sha1sum))) (let loop ((trynum 0)) (let ((dest-name (if (> trynum 0) (conc full-dest-file"-"trynum) full-dest-file))) (cond ((not (file-exists? srcf)) #f) ;; this should be an error? ((and (file-exists? srcf) (file-exists? dest-name)) (if (check-same srcf dest-name) (link-if-same-partition dest-name srcf) (loop (+ trynum 1)))) ;; collisions are rare, this protects against them ((not (file-exists? dest-name)) (link-or-copy srcf dest-name)) (else #f)))))) ;; multi-glob (define (multi-glob globstrs inpath) ;; (print "multi-glob: "globstrs", "inpath) (if (equal? inpath "") globstrs (let* ((parts (string-split inpath "/" #t)) (nextpart (car parts)) (remaining (string-intersperse (cdr parts) "/"))) (if (and (equal? nextpart "") ;; this must be a leading / meaning root directory (null? globstrs)) (multi-glob '("/") remaining) (begin ;; (print "nextpart="nextpart", remaining="remaining) (apply append (map (lambda (gstr) (let* ((pathstr (conc gstr"/"nextpart)) (pathstrs (glob pathstr))) ;; (print "pathstr="pathstr) (multi-glob pathstrs remaining))) globstrs))))))) ;; perm[/user:group]: ;; DDD - octal perm (future expansion) ;; - - use umask/defacto perms (i.e. don't actively do anything) ;; x - mark as executable ;; ;; Cards: ;; file: f perm fname ;; directory: d perm fname artifactid ;; link: l perm lname destpath ;; ;; NOTE: cards are kept as (C . "value") ;; ;; given a directory path, ignore list and artifact store (hash-table): ;; 1. create sha1 tree at dest (e.g. aa/b3a7 ...) ;; 2. create artifact for each dir ;; - cards for all files ;; - cards for files that are symlinks or executables ;; 3. return (artifactid . artifact) ;; ;; NOTES: ;; Use destdir of #f to not create sha1 tree ;; Hard links will be used if srcdir and destdir appear to be same partion ;; ;; (alist->artifact adat aspec #!key (ptype #f)) ;; ;; ;; (load "../../artifacts/artifacts.scm")(import big-chicken srfi-69 artifacts)(define dirdat (make-hash-table)) ;; (capture-dir ".." ".." "/tmp/junk" '() dirdat) ;; ;; [procedure] (file-type FILE [LINK [ERROR]]) ;; Returns the file-type for FILE, which should be a filename, a file-descriptor or a port object. If LINK is given and true, symbolic-links are not followed: ;; ;; regular-file ;; directory ;; fifo ;; socket ;; symbolic-link ;; character-device ;; block-device ;; Note that not all types are supported on every platform. If ERROR is given and false, then file-type returns #f if the file does not exist; otherwise, it signals an error. ;; ;; (define (capture-dir curr-dir src-dir dest-dir ignore-list artifacts all-seen) (let* ((dir-dat (directory-fold (lambda (fname res) ;; res is a list of artifact cards (let* ((fullname (conc curr-dir"/"fname))) ;; (print "INFO: processing "fullname) (if (hash-table-ref/default all-seen fullname #f) ;; something circular going on (begin (print "WARNING: possible circular link(s) "fullname) res) (let* ((ftype (file-type fullname #t #f))) (hash-table-set! all-seen fullname ftype) (cons (case ftype ;; get the card ((directory) ;; (directory? fullname) (let* ((new-curr-dir (conc curr-dir"/"fname)) (new-src-dir (conc src-dir"/"fname))) (let* ((dir-dat (capture-dir new-curr-dir new-src-dir dest-dir ignore-list artifacts all-seen)) (a-id (car dir-dat)) (artf (cdr dir-dat))) (hash-table-set! artifacts a-id artf) (cons 'd (conc "- "a-id" "fname))))) ;; the card ((symbolic-link) ;; (symbolic-link? fullname) (let ((ldest (read-symbolic-link fullname))) (cons 'l (conc "- "fname"/"ldest)))) ;; delimit link name from dest with / ((regular-file) ;; must be a file (let* ((start (current-seconds)) (sha1sum (file-get-sha1 fullname)) (perms (if (file-executable? fullname) "x" "-"))) (let ((runtime (- (current-seconds) start))) (if (> runtime 1) (print "INFO: file "fullname" took "runtime" seconds to calculate sha1."))) (if dest-dir (archive-copy fullname dest-dir sha1sum)) (cons 'f (conc perms " "sha1sum" "fname)))) (else (print "WARNING: file "fullname" of type "ftype" is NOT supported and will converted to empty file.") (let* ((sha1sum (write-to-archive "" dest-dir))) (cons 'f (conc "- "sha1sum" "fname))))) res))))) '() src-dir #:dotfiles? #t))) ;; => (values srcdir_artifact sub_artifacts_list) ;; (print "dir-dat: " dir-dat) (let-values (((a-id artf) (alist->artifact dir-dat '() ptype: 'd no-d: #t))) (hash-table-set! artifacts a-id artf) (cons a-id artf)))) ;; maybe move this into artifacts? ;; ;; currently moves *.artifact into a bundle and moves the artifacts into attic ;; future: move artifacts under 1 meg in size into bundle up to 10 meg in size ;; (define (artifact-rollup bundle-dir) ;; cfg storepath) ;; (let* ((bundle-dir (calc-bundle-dir cfg storepath))) (let* ((bundles (glob (conc bundle-dir"/*.bundle"))) (artifacts (glob (conc bundle-dir"/*.artifact")))) (if (> (length artifacts) 30) ;; rollup only if > 30 artifacts ;; if we have unbundled artifacts, bundle them (let* ((ht (read-artifacts-into-hash #f artifacts: artifacts)) (bundle (hash-of-artifacts->bundle ht))) (write-bundle bundle bundle-dir) (create-directory (conc bundle-dir"/attic") #t) (for-each (lambda (full-fname) (let* ((fname (pathname-strip-directory full-fname)) (newname (conc bundle-dir"/attic/"fname))) (move-file full-fname newname #t))) artifacts) (conc "bundled "(length artifacts))) "not enough artifacts to bundle"))) ;; if destfile is a directory then calculate the sha1sum of the bundle and store it ;; by <sha1sum>.bundle ;; ;; incoming dat is pure text (bundle already sorted and appended: ;; (define (write-bundle bdl-data destdir) (let* ((bdl-uuid (calc-sha1 bdl-data))) (with-output-to-file (conc destdir"/"bdl-uuid".bundle") (lambda () (print bdl-data))))) ;; minimal (and hopefully fast) artifact reader ;; TODO: Add check of shar sum. ;; (define (minimal-artifact-read fname) (let* ((indat (with-input-from-file fname read-lines))) (if (null? indat) (values #f (conc "did not find an artifact in "fname)) (let* ((zcard (last indat)) (cardk (substring zcard 0 1)) (cardv (substring zcard 2 (string-length zcard)))) (if (equal? cardk "Z") (values cardv (string-intersperse indat "\n")) (values #f (conc fname" is not a valid artifact"))))))) ;; read artifacts from directory into hash ;; NOTE: support for max-count not implemented yet ;; (define (read-artifacts-into-hash dir #!key (artifacts #f) (max-count #f)(ht #f)) (let* ((artifacts (or artifacts (glob (conc dir"/*.artifact")))) (ht (or ht (make-hash-table)))) (for-each (lambda (fname) (let-values (((uuid afct) (minimal-artifact-read fname))) (hash-table-set! ht uuid afct))) artifacts) ht)) ;; ht is: ;; uuid => artifact text ;; use write-bundle to put result into a bundle file ;; (define (hash-of-artifacts->bundle ht) (fold (lambda (k res) (let* ((v (hash-table-ref ht k))) (if res (conc res"\n"v) v))) #f (sort (hash-table-keys ht) string<=?))) ;; minimal artifact to alist ;; (define (minimal-artifact->alist afact) (let* ((lines (string-split afact "\n"))) (map (lambda (a) (let* ((key (string->symbol (substring a 0 1))) (sl (string-length a)) (val (if (> sl 2) (substring a 2 sl) ""))) (cons key val))) lines))) ;; some accessors for common cards (define (afact-get-D afact) (let ((dval (alist-ref 'D afact))) (if dval (string->number dval) #f))) (define (afact-get-T afact) ;; get the artifact type as a symbol (let ((val (alist-ref 'T afact))) (if val (string->symbol val) val))) (define (afact-get-Z afact) (alist-ref 'Z afact)) (define (afact-get afact key default) (or (alist-ref key afact) default)) (define (afact-get-number/default afact key default) (let ((val (alist-ref key afact))) (if val (or (string->number val) default) ;; seems wrong default))) ;; bundles are never big and reading into memory for processing is fine ;; (define (read-bundle srcfile #!optional (mode 'uuid-raw)) (let* ((indat (with-input-from-file srcfile read-lines))) (let loop ((tail indat) (dat '()) ;; artifact being extracted (res '())) ;; list of artifacts (if (null? tail) (reverse res) ;; last dat should be empty list (let* ((curr-line (car tail))) (let-values (((ctype cdata) (card->type/value curr-line))) (let* ((is-z-card (eq? 'Z ctype)) (new-dat (cons (case mode ((uuid-raw) curr-line) (else (cons ctype cdata))) dat))) (if is-z-card (loop (cdr tail) ;; done with this artifact '() (cons (case mode ((uuid-raw) (cons cdata (string-intersperse (reverse new-dat) "\n"))) (else (reverse new-dat))) res)) (loop (cdr tail) new-dat res))))))))) ;; find all .bundle and .artifacts files in bundle-dir ;; and inport them into sqlite handle adb ;; (define (refresh-artifacts-db adb bundle-dir) (let* ((bundles (glob (conc bundle-dir"/*.bundle"))) (artifacts (glob (conc bundle-dir"/*.artifact"))) (uuids (get-all-uuids adb 'hash))) (with-transaction adb (lambda () (for-each (lambda (bundle-file) ;; (print "Importing artifacts from "bundle-file) (let* ((bdat (read-bundle bundle-file 'uuid-raw)) (count 0) (inc (lambda ()(set! count (+ count 1))))) (for-each (lambda (adat) (match adat ((zval . artifact) (if (not (hash-table-exists? uuids zval)) (begin ;; (print "INFO: importing new artifact "zval" from bundle "bundle-file) (inc) (execute adb "INSERT INTO artifacts (uuid, artifact) VALUES (?,?);" zval artifact) (hash-table-set! uuids zval #t)))) (else (print "ERROR: Bad artifact data "adat)))) bdat) (print "INFO: imported "count" artifacts from "bundle-file))) bundles) (for-each (lambda (artifact-file) ;; (print "Importing artifact from "artifact-file) (let-values (((uuid artifact) (minimal-artifact-read artifact-file))) (if uuid (if (not (hash-table-exists? uuids uuid)) (begin ;; (print "INFO: importing new artifact "uuid" from "artifact-file) (execute adb "INSERT INTO artifacts (uuid, artifact) VALUES (?,?);" uuid artifact) (hash-table-set! uuids uuid #t))) (print "Bad artifact in "artifact-file)))) artifacts))))) ;;====================================================================== ;; Artifacts db cache ;;====================================================================== ;; artifacts ;; id SERIAL PRIMARY KEY, ;; uuid TEXT NOT NULL, ;; artifact TEXT NOT NULL ;; ;; parents ;; id INTEGER REFERENCES artids.id, -- ;; parent_id REFERENCES artids.id ;; ;; schema is list of SQL statements - can be used to extend db with more tables ;; (define (open-artifacts-db dbpath dbfile #!key (schema '())) (let* ((dbfname (conc dbpath "/" dbfile)) (dbexists (if (file-exists? dbfname) #t (begin (create-directory dbpath #t) #f))) (adb (open-database dbfname))) (set-busy-handler! adb (make-busy-timeout 10000)) (execute adb "PRAGMA synchronous = 0;") (if (not dbexists) (with-transaction adb (lambda () (for-each (lambda (stmt) (execute adb stmt)) (append `("CREATE TABLE IF NOT EXISTS artifacts (id INTEGER PRIMARY KEY, uuid TEXT NOT NULL, artifact TEXT NOT NULL)" "CREATE TABLE IF NOT EXISTS parents (id INTEGER REFERENCES artifacts(id) NOT NULL, parent_id INTEGER REFERENCES artifacts(id) NOT NULL)") schema))))) adb)) (define (generate-year-month-name #!optional (seconds #f)) (let* ((curr-time (seconds->local-time (or seconds (current-seconds))))) (time->string curr-time "%Y%m"))) ;; I don't like this function. TODO: remove the ;; mode and option to return ht. Use instead the ;; get-all-artifacts below ;; (define (get-all-uuids adb #!optional (mode #f)) (let* ((res (fold-row (lambda (res uuid) (cons uuid res)) '() adb "SELECT uuid FROM artifacts;"))) (case mode ((hash) (let* ((ht (make-hash-table))) (for-each (lambda (uuid) (hash-table-set! ht uuid #t)) res) ht)) (else res)))) ;; returns raw artifacts (i.e. NOT alists but instead plain text) (define (get-all-artifacts adb) (let* ((ht (make-hash-table))) (for-each-row (lambda (id uuid artifact) (hash-table-set! ht uuid `(,id ,uuid ,artifact))) adb "SELECT id,uuid,artifact FROM artifacts;") ht)) ;; given a bundle-dir copy or create to /tmp and open ;; the YYMM.db file and hand the handle to the given proc ;; NOTE: we operate in /tmp/ to accomodate users on NFS ;; where slamming Unix locks at an NFS filer can cause ;; locking fails. Eventually this /tmp behavior will be ;; configurable. ;; (define (with-todays-adb bundle-dir proc) (let* ((dbname (conc (generate-year-month-name) ".db")) (destname (conc bundle-dir"/"dbname)) (tmparea (conc "/tmp/"(current-user-name)"-"(calc-sha1 bundle-dir))) (tmpname (conc tmparea"/"dbname)) (lockfile (conc destname".update-in-progress"))) ;; (print "with-todays-adb, bundle-dir: "bundle-dir", dbname: "dbname", destname: "destname",\n tmparea: " tmparea", lockfile: "lockfile) (if (not (file-exists? tmparea))(create-directory tmparea #t)) (let loop ((count 0)) (if (file-exists? lockfile) (if (< count 30) ;; aproximately 30 seconds (begin (sleep 1) (loop (+ 1 count))) (print "ERROR: "lockfile" exists, proceeding anyway")) (if (file-exists? destname) (begin (copy-file destname tmpname #t) (copy-file destname lockfile #t))))) (let* ((adb (open-artifacts-db tmparea dbname)) (res (proc adb))) (finalize! adb) (copy-file tmpname destname #t) (delete-file* lockfile) res))) ) ;; module artifacts ;; ATTIC |
Added artifacts/artifacts.setup version [bf666feb42].
> > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 | ;; Copyright 2007-2017, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;;; pkts.setup (standard-extension 'pkts "1.0") |
Added artifacts/artifactsrec.scm version [28997466b3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (define-syntax define-record-type (syntax-rules () ((define-record-type type (constructor constructor-tag ...) predicate (field-tag accessor . more) ...) (begin (define type (make-record-type 'type '(field-tag ...))) (define constructor (record-constructor type '(constructor-tag ...))) (define predicate (record-predicate type)) (define-record-field type field-tag accessor . more) ...)))) ; An auxilliary macro for define field accessors and modifiers. ; This is needed only because modifiers are optional. (define-syntax define-record-field (syntax-rules () ((define-record-field type field-tag accessor) (define accessor (record-accessor type 'field-tag))) ((define-record-field type field-tag accessor modifier) (begin (define accessor (record-accessor type 'field-tag)) (define modifier (record-modifier type 'field-tag)))))) ; Record types ; We define the following procedures: ; ; (make-record-type <type-name <field-names>) -> <record-type> ; (record-constructor <record-type<field-names>) -> <constructor> ; (record-predicate <record-type>) -> <predicate> ; (record-accessor <record-type <field-name>) -> <accessor> ; (record-modifier <record-type <field-name>) -> <modifier> ; where ; (<constructor> <initial-value> ...) -> <record> ; (<predicate> <value>) -> <boolean> ; (<accessor> <record>) -> <value> ; (<modifier> <record> <value>) -> <unspecific> ; Record types are implemented using vector-like records. The first ; slot of each record contains the record's type, which is itself a ; record. (define (record-type record) (record-ref record 0)) ;---------------- ; Record types are themselves records, so we first define the type for ; them. Except for problems with circularities, this could be defined as: ; (define-record-type :record-type ; (make-record-type name field-tags) ; record-type? ; (name record-type-name) ; (field-tags record-type-field-tags)) ; As it is, we need to define everything by hand. (define :record-type (make-record 3)) (record-set! :record-type 0 :record-type) ; Its type is itself. (record-set! :record-type 1 ':record-type) (record-set! :record-type 2 '(name field-tags)) ; Now that :record-type exists we can define a procedure for making more ; record types. (define (make-record-type name field-tags) (let ((new (make-record 3))) (record-set! new 0 :record-type) (record-set! new 1 name) (record-set! new 2 field-tags) new)) ; Accessors for record types. (define (record-type-name record-type) (record-ref record-type 1)) (define (record-type-field-tags record-type) (record-ref record-type 2)) ;---------------- ; A utility for getting the offset of a field within a record. (define (field-index type tag) (let loop ((i 1) (tags (record-type-field-tags type))) (cond ((null? tags) (error "record type has no such field" type tag)) ((eq? tag (car tags)) i) (else (loop (+ i 1) (cdr tags)))))) ;---------------- ; Now we are ready to define RECORD-CONSTRUCTOR and the rest of the ; procedures used by the macro expansion of DEFINE-RECORD-TYPE. (define (record-constructor type tags) (let ((size (length (record-type-field-tags type))) (arg-count (length tags)) (indexes (map (lambda (tag) (field-index type tag)) tags))) (lambda args (if (= (length args) arg-count) (let ((new (make-record (+ size 1)))) (record-set! new 0 type) (for-each (lambda (arg i) (record-set! new i arg)) args indexes) new) (error "wrong number of arguments to constructor" type args))))) (define (record-predicate type) (lambda (thing) (and (record? thing) (eq? (record-type thing) type)))) (define (record-accessor type tag) (let ((index (field-index type tag))) (lambda (thing) (if (and (record? thing) (eq? (record-type thing) type)) (record-ref thing index) (error "accessor applied to bad value" type tag thing))))) (define (record-modifier type tag) (let ((index (field-index type tag))) (lambda (thing value) (if (and (record? thing) (eq? (record-type thing) type)) (record-set! thing index value) (error "modifier applied to bad value" type tag thing))))) Records ; This implements a record abstraction that is identical to vectors, ; except that they are not vectors (VECTOR? returns false when given a ; record and RECORD? returns false when given a vector). The following ; procedures are provided: ; (record? <value>) -> <boolean> ; (make-record <size>) -> <record> ; (record-ref <record> <index>) -> <value> ; (record-set! <record> <index> <value>) -> <unspecific> ; ; These can implemented in R5RS Scheme as vectors with a distinguishing ; value at index zero, providing VECTOR? is redefined to be a procedure ; that returns false if its argument contains the distinguishing record ; value. EVAL is also redefined to use the new value of VECTOR?. ; Define the marker and redefine VECTOR? and EVAL. (define record-marker (list 'record-marker)) (define real-vector? vector?) (define (vector? x) (and (real-vector? x) (or (= 0 (vector-length x)) (not (eq? (vector-ref x 0) record-marker))))) ; This won't work if ENV is the interaction environment and someone has ; redefined LAMBDA there. (define eval (let ((real-eval eval)) (lambda (exp env) ((real-eval `(lambda (vector?) ,exp)) vector?)))) ; Definitions of the record procedures. (define (record? x) (and (real-vector? x) (< 0 (vector-length x)) (eq? (vector-ref x 0) record-marker))) (define (make-record size) (let ((new (make-vector (+ size 1)))) (vector-set! new 0 record-marker) new)) (define (record-ref record index) (vector-ref record (+ index 1))) (define (record-set! record index value) (vector-set! record (+ index 1) value)) |
Added artifacts/tests/run.scm version [957c7c2ae2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (use test) ;; (use (prefix pkts pkts:)) (use pkts (prefix dbi dbi:)) ;; (use trace)(trace sdat->alist pkt->alist) (if (file-exists? "queue.db")(delete-file "queue.db")) (test-begin "pkts and pkt archives") ;;====================================================================== ;; Basic pkt creation, parsing and conversion routines ;;====================================================================== (test-begin "basic packets") (test #f '(A "This is a packet") (let-values (((t v) (card->type/value "A This is a packet"))) (list t v))) (test #f "A A\nZ 664449e7299e0065a3e25c138ccef2df13ba291e" (let-values (((uuid res) (add-z-card '("A A")))) res)) (test #f '("CC C++" "D 1486332719.0" "a A" "b C")(sort (construct-sdat 'b "C" 'a "A" 'CC "C++" 'D 1486332719.0) string<=?)) (define pkt-example #f) (test #f "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84" (let-values (((uuid res) (construct-pkt 'b "C" 'a "A" 'CC "C++" 'D 1486332719.0))) (set! pkt-example (cons uuid res)) res)) (test-end "basic packets") ;;====================================================================== ;; Sqlite and postgresql based queue of pkts ;;====================================================================== (test-begin "pkt queue") (define db #f) (test #f 'sqlite3 (let ((dbh (open-queue-db "." "queue.db"))) (set! db dbh) (dbi:db-dbtype dbh))) (test #f (cdr pkt-example) (begin (add-to-queue db (cdr pkt-example)(car pkt-example) 'basic #f 0) (lookup-by-uuid db (car pkt-example) 0))) (test #f (cdr pkt-example) (lookup-by-id db 1)) (test #f 1 (length (find-pkts db '(basic) '()))) (test-end "pkt queue") ;;====================================================================== ;; Process groups of pkts ;;====================================================================== (test-begin "lists of packets") (test #f '((apkt . #f) (id . 1) (group-id . 2) (uuid . 3) (parent . 4) (pkt-type . 5)) ;; ((id . 1) (group-id . 2) (uuid . 3) (parent . 4) (pkt-type . 5)) (dblst->dpkts '(1 2 3 4 5))) (test #f '(((apkt (Z . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (b . "C") (a . "A") (D . "1486332719.0") (C . " C++")) (id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (processed . 0))) ;; '(((apkt (Z . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (b . "C") (a . "A") (D . "1486332719.0") (C . " C++")) (id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84"))) ;; '(((id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84"))) (get-dpkts db '(basic) 0 #f)) (test #f '(((apkt (Z . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (b . "C") (a . "A") (D . "1486332719.0") (C . " C++")) (id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (processed . 0))) ;; '(((apkt (Z . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (b . "C") (a . "A") (D . "1486332719.0") (C . " C++")) (id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84"))) ;; '(((id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84"))) (get-not-processed-pkts db 0 'basic 1000 0)) (test-end "lists of packets") (test-begin "pkts as alists") (define pktspec '((posting . ((title . t) ;; NOTE: same as ((posting (title . t)(url . u)(blub . b)) ... (url . u) (blurb . b))) (comment . ((comment . c) (score . s))) (basic . ((b-field . b) (a-field . a))))) (define pktlst (find-pkts db '(basic) '())) (define dpkt (car pktlst)) (test #f "A" (get-value 'a-field dpkt pktspec)) (test #f "C" (alist-ref 'b-field (dpkt->alist dpkt pktspec))) (define basic-spec '((nada (foo . b)(bar . f))(basic (foo . f)(bar . b)))) (define test-pkt '((foo . "fooval")(bar . "barval"))) (let*-values (((u p) (alist->pkt test-pkt basic-spec ptype: 'basic)) ((apkt) (pkt->alist p)) ((bpkt) (pkt->alist p pktspec: basic-spec))) (test #f "fooval" (alist-ref 'f apkt)) (test #f "fooval" (alist-ref 'foo bpkt)) (test #f #f (alist-ref 'f bpkt))) (test-end "pkts as alists") (test-begin "descendents and ancestors") (define (get-uuid pkt)(alist-ref 'uuid pkt)) ;; add a child to 263e (let-values (((uuid pkt) (construct-pkt 'x "X" 'y "Y" 'P "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84" 'D "1486332719.0"))) (add-to-queue db pkt uuid 'basic "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84" 0)) (test #f '("263eb3b6193de7fe65b1ded5bcda513e8b4d6b84" "818fe30988c9673441b8f203972a8bda6af682f8") (map (lambda (x)(alist-ref 'uuid x)) (get-descendents db 0 "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84"))) (test #f '("263eb3b6193de7fe65b1ded5bcda513e8b4d6b84" "818fe30988c9673441b8f203972a8bda6af682f8") (map (lambda (x)(alist-ref 'uuid x)) (get-ancestors db 0 "818fe30988c9673441b8f203972a8bda6af682f8"))) (test-end "descendents and ancestors") (test-end "pkts and pkt archives") (test-begin "pktsdb") (define spec '((tests (testname n TEXT) (testpath p TEXT) (duration d INTEGER)))) ;; (define pktsdb (make-pktdb)) ;; (pktdb-pktsdb-spec-set! pktsdb spec) (define pktsdb #f) (test #f #t (dbi:database? (let ((pdb (pktsdb-open "test.db" spec))) (set! pktsdb pdb) (pktdb-conn pdb)))) ;; (pp (pktdb-pktspec pktsdb)) (test #f #t (pktsdb-add-record pktsdb 'tests '((testname . "test1")))) (pktsdb-close pktsdb) (test-end "pktsdb") |
Renamed and modified client.scm [9da8d7475d] to attic/client.scm [f0a5f3a990].
︙ | ︙ | |||
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/>. ;;====================================================================== ;; C L I E N T S ;;====================================================================== | < < < < > > > > > > > > > > > > > > > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 | ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== ;; C L I E N T S ;;====================================================================== (declare (unit client)) (declare (uses common)) (declare (uses db)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. (declare (uses commonmod)) (use srfi-18 extras tcp s11n srfi-1 posix regex srfi-69 hostinfo md5 message-digest matchable spiffy uri-common intarweb http-client spiffy-request-vars uri-common intarweb directory-utils) (import commonmod debugprint) (module client * ) (import client) (include "common_records.scm") (include "db_records.scm") |
Name change from filedb.scm to attic/filedb.scm.
︙ | ︙ |
Name change from ftail.scm to attic/ftail.scm.
︙ | ︙ |
Renamed and modified http-transport.scm [92b19b8dad] to attic/http-transport.scm [235baaba81].
︙ | ︙ | |||
12 13 14 15 16 17 18 | ;; 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/>. | < < < < < < < < < < < > > > > > > > > > > > > > > > > > > > > > > > > | > | 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 | ;; 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 http-transport)) (declare (uses common)) (declare (uses debugprint)) (declare (uses db)) (declare (uses tests)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. (declare (uses server)) ;; (declare (uses daemon)) (declare (uses portlogger)) (declare (uses rmt)) (declare (uses dbfile)) (declare (uses commonmod)) (declare (uses mtargs)) (module http-transport * (import srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing (srfi 18) extras tcp s11n) (import scheme chicken (prefix mtargs args:) debugprint) ;; Configurations for server (tcp-buffer-size 2048) (max-connections 2048) (include "common_records.scm") (include "db_records.scm") (include "js-path.scm") (import dbfile commonmod) (require-library stml) (define (http-transport:make-server-url hostport) (if (not hostport) #f (conc "http://" (car hostport) ":" (cadr hostport)))) (define *server-loop-heart-beat* (current-seconds)) |
︙ | ︙ | |||
95 96 97 98 99 100 101 | ;; This is were we set up the database connections (let* (($ (request-vars source: 'both)) (dat ($ 'dat)) (res #f)) (cond ((equal? (uri-path (request-uri (current-request))) '(/ "api")) | | | 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 | ;; This is were we set up the database connections (let* (($ (request-vars source: 'both)) (dat ($ 'dat)) (res #f)) (cond ((equal? (uri-path (request-uri (current-request))) '(/ "api")) (send-response body: (api:process-request *dbstruct-dbs* $) ;; the $ is the request vars proc headers: '((content-type text/plain))) (mutex-lock! *heartbeat-mutex*) (set! *db-last-access* (current-seconds)) (mutex-unlock! *heartbeat-mutex*)) ((equal? (uri-path (request-uri (current-request))) '(/ "")) (send-response body: (http-transport:main-page))) |
︙ | ︙ | |||
147 148 149 150 151 152 153 | (config-use-proxy (equal? (configf:lookup *configdat* "client" "use-http_proxy") "yes"))) (if (not config-use-proxy) (determine-proxy (constantly #f))) (debug:print-info 0 *default-log-port* "http-transport:try-start-server time=" (seconds->time-string (current-seconds)) " ipaddrsstr=" ipaddrstr " portnum=" portnum " config-hostname=" config-hostname) (handle-exceptions exn (begin | | | | | | | 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 | (config-use-proxy (equal? (configf:lookup *configdat* "client" "use-http_proxy") "yes"))) (if (not config-use-proxy) (determine-proxy (constantly #f))) (debug:print-info 0 *default-log-port* "http-transport:try-start-server time=" (seconds->time-string (current-seconds)) " ipaddrsstr=" ipaddrstr " portnum=" portnum " config-hostname=" config-hostname) (handle-exceptions exn (begin ;; (print-error-message exn) (if (< portnum 64000) (begin (debug:print 0 *default-log-port* "WARNING: attempt to start server failed. Trying again ...") (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 5 *default-log-port* "exn=" (condition->list exn)) (portlogger:open-run-close portlogger:set-failed portnum) (debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port") (thread-sleep! 0.1) ;; get_next_port goes here (http-transport:try-start-server ipaddrstr (portlogger:open-run-close portlogger:find-port))) (begin (debug:print 0 *default-log-port* "ERROR: Tried and tried but could not start the server")))) ;; any error in following steps will result in a retry (set! *server-info* (list ipaddrstr portnum)) (debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum) ;; This starts the spiffy server ;; NEED WAY TO SET IP TO #f TO BIND ALL ;; (start-server bind-address: ipaddrstr port: portnum) (if config-hostname ;; this is a hint to bind directly (start-server port: portnum) ;; bind-address: (if (equal? config-hostname "-") ;; ipaddrstr ;; config-hostname)) (start-server port: portnum)) (portlogger:open-run-close portlogger:set-port portnum "released") (debug:print 1 *default-log-port* "INFO: server has been stopped")))) ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== |
︙ | ︙ | |||
235 236 237 238 239 240 241 | (define (http-transport:inc-requests-and-prep-to-close-all-connections) (mutex-lock! *http-mutex*) (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*))) ;; Send "cmd" with json payload "params" to serverdat and receive result ;; | | < < < | < > | | > | 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 | (define (http-transport:inc-requests-and-prep-to-close-all-connections) (mutex-lock! *http-mutex*) (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*))) ;; Send "cmd" with json payload "params" to serverdat and receive result ;; (define (http-transport:client-api-send-receive run-id runremote cmd params #!key (numretries 3)) (assert (remote? runremote) "FATAL: http-transport:client-api-send-receive called with serverdat="serverdat) (let* ((fullurl (remote-api-req runremote)) (res (vector #f "uninitialized")) (success #t) (sparams (db:obj->string params transport: 'http)) (server-id (remote-server-id runremote))) (debug:print-info 11 *default-log-port* "cmd=" cmd " fullurl=" fullurl " server-id=" server-id " current time:" (current-seconds)) ;; set up the http-client here (max-retry-attempts 1) ;; consider all requests indempotent (retry-request? (lambda (request) #f)) ;; send the data and get the response ;; extract the needed info from the http data and |
︙ | ︙ | |||
271 272 273 274 275 276 277 | (msg ((condition-property-accessor 'exn 'message) exn))) (set! success #f) (if (debug:debug-mode 1) (debug:print-info 0 *default-log-port* "couldn't talk to server, trying again ...") (begin (debug:print 0 *default-log-port* "WARNING: failure in with-input-from-request to " fullurl ".") (debug:print 0 *default-log-port* " message: " msg ", exn=" exn) | | > | < < < | < < | | | | | | | | > < | > > > > > > | | < < | < < | | | | | > > | < < < | < < < < > | < < < | < < < | < < < < < < < < < < < < < < < < < < < < > | > > > > > > > > > > > > > > > > | > > < < < < < < | > > > | < < < | < < < | > > | | | > > > > > > | | 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 | (msg ((condition-property-accessor 'exn 'message) exn))) (set! success #f) (if (debug:debug-mode 1) (debug:print-info 0 *default-log-port* "couldn't talk to server, trying again ...") (begin (debug:print 0 *default-log-port* "WARNING: failure in with-input-from-request to " fullurl ".") (debug:print 0 *default-log-port* " message: " msg ", exn=" exn) (debug:print 0 *default-log-port* " cmd: " cmd " params: " params " key:" (or server-id "thekey")) (debug:print 0 *default-log-port* " call-chain: " call-chain))) ;; what if another thread is communicating ok? Can't happen due to mutex (http-transport:close-connections runremote) (mutex-unlock! *http-mutex*) ;; (close-connection! fullurl) (db:obj->string #f)) (with-input-from-request ;; was dat fullurl (list (cons 'key (or server-id "thekey")) (cons 'cmd cmd) (cons 'params sparams)) read-string)) transport: 'http) 0)) ;; added this speculatively ;; Shouldn't this be a call to the managed call-all-connections stuff above? ;; (close-all-connections!) ;; BUG? WHY IS THIS HERE? Are we failing to reuse connections? (mutex-unlock! *http-mutex*) )) (time-out (lambda () (thread-sleep! 45) (debug:print 0 *default-log-port* "WARNING: send-receive took more than 45 seconds!!") #f)) (th1 (make-thread send-recieve "with-input-from-request")) (th2 (make-thread time-out "time out"))) (thread-start! th1) (thread-start! th2) (thread-join! th1) (vector-set! res 0 success) (thread-terminate! th2) (if (vector? res) (if (vector-ref res 0) ;; this is the first flag or the second flag? (let* ((res-dat (vector-ref res 1))) (if (and (string? res-dat) (string-contains res-dat "server-id mismatch")) (signal (make-composite-condition (make-property-condition 'servermismatch 'message (vector-ref res 1)))) res)) ;; this is the *inner* vector? seriously? why? (if (debug:debug-mode 11) (let ((call-chain (get-call-chain))) ;; note: this code also called in nmsg-transport - consider consolidating it (print-call-chain (current-error-port)) (debug:print-error 11 *default-log-port* "error above occured at server, res=" res) ;; " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 11 *default-log-port* " server call chain:") (pp (vector-ref res 1) (current-error-port)) (signal (vector-ref res 0))) res)) (signal (make-composite-condition (make-property-condition 'timeout 'message "nmsg-transport:client-api-send-receive-raw timed out talking to server"))))))) ;; careful closing of connections stored in *runremote* ;; (define (http-transport:close-connections runremote) (if (remote? runremote) (let ((api-dat (remote-api-uri runremote))) (handle-exceptions exn (begin (print-call-chain *default-log-port*) (debug:print-error 0 *default-log-port* " closing connection failed with error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)) (if (args:any-defined? "-server" "-execute" "-run") (debug:print-info 0 *default-log-port* "Closing connections to "api-dat)) (if api-dat (close-connection! api-dat)) ;; Would it be better to set *runremote* to #f? I don't think so. But we may ;; need to clear more of the runremote fields (remote-api-url-set! runremote #f) ;; used as a flag for connection up and running #t)) #f)) ;; run http-transport:keep-running in a parallel thread to monitor that the db is being ;; used and to shutdown after sometime if it is not. ;; (define (http-transport:keep-running) ;; if none running or if > 20 seconds since ;; server last used then start shutdown ;; This thread waits for the server to come alive (debug:print-info 0 *default-log-port* "Starting the sync-back, keep alive thread in server") (let* ((servinfofile #f) (sdat #f) (no-sync-db (db:open-no-sync-db)) (tmp-area (common:get-db-tmp-area)) (started-file (conc tmp-area "/.server-started")) (server-start-time (current-seconds)) (server-info (let loop ((start-time (current-seconds)) (changed #t) (last-sdat "not this")) (begin ;; let ((sdat #f)) (thread-sleep! 0.01) (debug:print-info 0 *default-log-port* "Waiting for server alive signature") (mutex-lock! *heartbeat-mutex*) (set! sdat *server-info*) (mutex-unlock! *heartbeat-mutex*) (if (and sdat (not changed) (> (- (current-seconds) start-time) 2)) (let* ((servinfodir (server:get-servinfo-dir *toppath*)) ;; (conc *toppath*"/.servinfo")) (ipaddr (car sdat)) (port (cadr sdat)) (servinf (conc servinfodir"/"ipaddr":"port))) (set! servinfofile servinf) (if (not (file-exists? servinfodir)) (create-directory servinfodir #t)) (with-output-to-file servinf (lambda () (let* ((serv-id (server:mk-signature))) (set! *server-id* serv-id) (print "SERVER STARTED: "ipaddr":"port" AT "(current-seconds)" server-id: "serv-id" pid: "(current-process-id)) (print "started: "(seconds->year-week/day-time (current-seconds)))))) (set! *on-exit-procs* (cons (lambda () (delete-file* servinf)) *on-exit-procs*)) ;; put data about this server into a simple flat file host.port (debug:print-info 0 *default-log-port* "Received server alive signature") sdat) (begin (debug:print-info 0 *default-log-port* "Still waiting, last-sdat=" last-sdat) (sleep 4) (if (> (- (current-seconds) start-time) 120) ;; been waiting for two minutes (if sdat (let* ((ipaddr (car sdat)) (port (cadr sdat)) (servinf (conc (server:get-servinfo-dir *toppath*)"/"ipaddr":"port))) (debug:print-error 0 *default-log-port* "transport appears to have died, exiting server") (exit)) (exit) ) (loop start-time (equal? sdat last-sdat) sdat))))))) (iface (car server-info)) (port (cadr server-info)) (last-access 0) (server-timeout (server:expiration-timeout)) (server-going #f) (server-log-file (args:get-arg "-log"))) ;; always set when we are a server (handle-exceptions exn (debug:print 0 *default-log-port* "Failed to create " started-file ", exn=" exn) (with-output-to-file started-file (lambda ()(print (current-process-id))))) (let loop ((count 0) (server-state 'available) (bad-sync-count 0) (start-time (current-milliseconds))) ;; Use this opportunity to sync the tmp db to megatest.db (if (not server-going) ;; *dbstruct-dbs* (begin (debug:print 0 *default-log-port* "SERVER: dbprep") (set! *dbstruct-dbs* (db:setup #t)) ;; run-id)) FIXME!!! (set! server-going #t) (debug:print 0 *default-log-port* "SERVER: running, megatest version: " (common:get-full-version))) ;; NOTE: the server is NOT yet marked as running in the log. We do that in the keep-running routine. (if (and no-sync-db (common:low-noise-print 10 "sync-all")) ;; cheesy way to reduce frequency of running sync :) (begin (if (common:low-noise-print 120 "sync-all-print") (debug:print 0 *default-log-port* "keep-running calling db:all-db-sync at " (time->string (seconds->local-time) "%H:%M:%S"))) (db:all-db-sync *dbstruct-dbs*) ))) ;; when things go wrong we don't want to be doing the various queries too often ;; so we strive to run this stuff only every four seconds or so. (let* ((sync-time (- (current-milliseconds) start-time)) (rem-time (quotient (- 4000 sync-time) 1000))) (if (and (<= rem-time 4) (> rem-time 0)) |
︙ | ︙ | |||
473 474 475 476 477 478 479 | (if (not (equal? sdat (list iface port))) (let ((new-iface (car sdat)) (new-port (cadr sdat))) (debug:print-info 0 *default-log-port* "WARNING: interface changed, refreshing iface and port info") (set! iface new-iface) (set! port new-port) | > > | > > > | | | > | > | > > > > > > > > > | 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 | (if (not (equal? sdat (list iface port))) (let ((new-iface (car sdat)) (new-port (cadr sdat))) (debug:print-info 0 *default-log-port* "WARNING: interface changed, refreshing iface and port info") (set! iface new-iface) (set! port new-port) (if (not *server-id*) (set! *server-id* (server:mk-signature))) (debug:print 0 *default-log-port* "SERVER STARTED: " iface ":" port " AT " (current-seconds) " server-id: " *server-id*) (flush-output *default-log-port*))) ;; Transfer *db-last-access* to last-access to use in checking that we are still alive (mutex-lock! *heartbeat-mutex*) (set! last-access *db-last-access*) (mutex-unlock! *heartbeat-mutex*) (if (common:low-noise-print 120 (conc "server running on " iface ":" port)) (begin (if (not *server-id*) (set! *server-id* (server:mk-signature))) (debug:print 0 *default-log-port* (current-seconds) (current-directory) (current-process-id) (argv)) (debug:print 0 *default-log-port* "SERVER STARTED: " iface ":" port " AT " (current-seconds) " server-id: " *server-id*) (flush-output *default-log-port*))) (if (common:low-noise-print 60 "dbstats") (begin (debug:print 0 *default-log-port* "Server stats:") (db:print-current-query-stats))) (let* ((hrs-since-start (/ (- (current-seconds) server-start-time) 3600))) (cond ((and *server-run* (> (+ last-access server-timeout) (current-seconds))) (if (common:low-noise-print 120 "server continuing") (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) (let ((curr-time (current-seconds))) (handle-exceptions exn (debug:print 0 *default-log-port* "ERROR: Failed to change timestamp on info file " servinfofile ". Are you out of space on that disk? exn=" exn) (if (and ;; (< (- (current-seconds) server-start-time) 600) ;; run for ten minutes for experiment, 3600 thereafter (not *server-overloaded*) (file-exists? servinfofile)) (change-file-times servinfofile curr-time curr-time))) (if (and (common:low-noise-print 120 "start new server") (> *api-process-request-count* 50)) ;; if this server is kind of busy start up another (begin (debug:print-info 0 *default-log-port* "Server is busy, api-count "*api-process-request-count*", start another if possible...") (server:kind-run *toppath*) (if (> *api-process-request-count* 100) (begin (debug:print-info 0 *default-log-port* "Server is overloaded at api-count=" *api-process-request-count*", removing "servinfofile) (delete-file* servinfofile))))))) (loop 0 server-state bad-sync-count (current-milliseconds))) (else (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access)) (http-transport:server-shutdown port))))))) (define (http-transport:server-shutdown port) (begin |
︙ | ︙ | |||
535 536 537 538 539 540 541 | ;; (if (eq? *number-non-write-queries* 0) ;; "n/a (no queries)" ;; (/ *total-non-write-delay* ;; *number-non-write-queries*)) ;; " ms") (db:print-current-query-stats) | | | > > > | | | < < < < < < < < < < < < < < < < < < < < | < < < < < < | | | | < < | | | | | | | | | | | | | | | | | | 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 | ;; (if (eq? *number-non-write-queries* 0) ;; "n/a (no queries)" ;; (/ *total-non-write-delay* ;; *number-non-write-queries*)) ;; " ms") (db:print-current-query-stats) #;(common:save-pkt `((action . exit) (T . server) (pid . ,(current-process-id))) *configdat* #t) ;; remove .servinfo file(s) here (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting") (exit))) ;; all routes though here end in exit ... ;; ;; start_server? ;; (define (http-transport:launch) ;; check the .servinfo directory, are there other servers running on this ;; or another host? (let* ((server-start-is-ok (server:minimal-check *toppath*))) (if (not server-start-is-ok) (begin (debug:print 0 *default-log-port* "ERROR: server start not ok, exiting now.") (exit 1)))) ;; check that a server start is in progress, pause or exit if so (let* ((th2 (make-thread (lambda () (debug:print-info 0 *default-log-port* "Server run thread started") (http-transport:run (if (args:get-arg "-server") (args:get-arg "-server") "-") )) "Server run")) (th3 (make-thread (lambda () (debug:print-info 0 *default-log-port* "Server monitor thread started") (http-transport:keep-running) "Keep running")))) (thread-start! th2) (thread-sleep! 0.25) ;; give the server time to settle before starting the keep-running monitor. (thread-start! th3) (set! *didsomething* #t) (thread-join! th2) (exit))) ;; (define (http-transport:server-signal-handler signum) ;; (signal-mask! signum) ;; (handle-exceptions ;; exn ;; (debug:print 0 *default-log-port* " ... exiting ...") ;; (let ((th1 (make-thread (lambda () |
︙ | ︙ | |||
712 713 714 715 716 717 718 | (conc "<table>" (string-intersperse (map (lambda (stat) (conc "<tr><td>" (car stat) "</td><td>" (cadr stat) "</td></tr>")) stats) " ") "</table>"))) | > | 701 702 703 704 705 706 707 708 | (conc "<table>" (string-intersperse (map (lambda (stat) (conc "<tr><td>" (car stat) "</td><td>" (cadr stat) "</td></tr>")) stats) " ") "</table>"))) ) |
Renamed and modified index-tree.scm [10c620fbfc] to attic/index-tree.scm [6384bce0d0].
︙ | ︙ | |||
27 28 29 30 31 32 33 34 35 36 37 38 39 40 | (declare (unit tests)) (declare (uses lock-queue)) (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") | > > | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | (declare (unit tests)) (declare (uses lock-queue)) (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) (declare (uses commonmod)) (import commonmod) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") |
︙ | ︙ |
Renamed and modified lock-queue.scm [21543b63ce] to attic/lock-queue.scm [5f0ac4e80e].
︙ | ︙ | |||
16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; (use (prefix sqlite3 sqlite3:) srfi-18) (declare (unit lock-queue)) (declare (uses common)) (declare (uses tasks)) ;;====================================================================== ;; attempt to prevent overlapping updates of rollup files by queueing ;; update requests in an sqlite db ;;====================================================================== ;;====================================================================== | > > > > > | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 | ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; (use (prefix sqlite3 sqlite3:) srfi-18) (declare (unit lock-queue)) (declare (uses common)) (declare (uses debugprint)) (declare (uses tasks)) (declare (uses commonmod)) (import commonmod debugprint) ;;====================================================================== ;; attempt to prevent overlapping updates of rollup files by queueing ;; update requests in an sqlite db ;;====================================================================== ;;====================================================================== |
︙ | ︙ |
Renamed and modified margs.scm [812fd1b225] to attic/margs.scm [d9dd6e93ad].
︙ | ︙ | |||
22 23 24 25 26 27 28 | (define args:arg-hash (make-hash-table)) (define (args:get-arg arg . default) (if (null? default) (hash-table-ref/default args:arg-hash arg #f) (hash-table-ref/default args:arg-hash arg (car default)))) | > | > > > > | > | > > > > > > > > > | | | | | | | | | 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 | (define args:arg-hash (make-hash-table)) (define (args:get-arg arg . default) (if (null? default) (hash-table-ref/default args:arg-hash arg #f) (hash-table-ref/default args:arg-hash arg (car default)))) ;; get an arg as a number (define (args:get-arg-number arg . default) (let* ((val-str (args:get-arg arg)) (val (if val-str (string->number val-str) #f))) (if val val (if (null? default) #f default)))) (define (args:get-arg-from ht arg . default) (if (null? default) (hash-table-ref/default ht arg #f) (hash-table-ref/default ht arg (car default)))) (define (args:remove-arg-from-ht arg) (hash-table-delete! args:arg-hash arg) ) (define (args:usage . args) (if (> (length args) 0) (apply print "ERROR: " args)) (if (string? help) (print help) (print "Usage: " (car (argv)) " ... ")) (exit 0)) (define (args:any-defined? . args) (not (null? (filter (lambda (x) x) (map args:get-arg args))))) ;; ;; one-of args defined ;; (define (args:any-defined? . param) ;; (let ((res #f)) ;; (for-each ;; (lambda (arg) ;; (if (args:get-arg arg)(set! res #t))) ;; param) ;; res)) ;; args: (define (args:get-args args params switches arg-hash num-needed) (let* ((numargs (length args)) (adj-num-needed (if num-needed (+ num-needed 2) #f))) (if (< numargs (if adj-num-needed adj-num-needed 2)) (if (>= num-needed 1) |
︙ | ︙ |
Renamed and modified mlaunch.scm [5bcd34288f] to attic/mlaunch.scm [62be2ae3e1].
︙ | ︙ | |||
26 27 28 29 30 31 32 33 | ;;====================================================================== (use sqlite3 srfi-1 posix regex regex-case srfi-69 format) (declare (unit mlaunch)) (declare (uses db)) (declare (uses common)) | > > | 26 27 28 29 30 31 32 33 34 35 | ;;====================================================================== (use sqlite3 srfi-1 posix regex regex-case srfi-69 format) (declare (unit mlaunch)) (declare (uses db)) (declare (uses common)) (declare (uses commonmod)) (import commonmod) |
Name change from portlogger-example.scm to attic/portlogger-example.scm.
︙ | ︙ |
Name change from records-vs-vectors-vs-coops.scm to attic/records-vs-vectors-vs-coops.scm.
︙ | ︙ |
Name change from runs-launch-loop-test.scm to attic/runs-launch-loop-test.scm.
︙ | ︙ |
Name change from sdb.scm to attic/sdb.scm.
︙ | ︙ |
Renamed and modified synchash.scm [6d4566e942] to attic/synchash.scm [6e3717b1e0].
︙ | ︙ | |||
25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | (use format) (use srfi-1 srfi-69 sqlite3) (import (prefix sqlite3 sqlite3:)) (declare (unit synchash)) (declare (uses db)) (declare (uses server)) (include "db_records.scm") (define (synchash:make) (make-hash-table)) ;; given an alist of objects '((id obj) ...) ;; 1. remove unchanged objects from the list ;; 2. create a list of removed objects by id | > > > > | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | (use format) (use srfi-1 srfi-69 sqlite3) (import (prefix sqlite3 sqlite3:)) (declare (unit synchash)) (declare (uses db)) (declare (uses server)) (declare (uses rmtmod)) (include "db_records.scm") (import rmtmod) (define (synchash:make) (make-hash-table)) ;; given an alist of objects '((id obj) ...) ;; 1. remove unchanged objects from the list ;; 2. create a list of removed objects by id |
︙ | ︙ |
Name change from vg-test.scm to attic/vg-test.scm.
︙ | ︙ |
Added bin/.11/lib/libpangox-1.0.so version [d55c756a93].
cannot compute difference between binary files
Added bin/.11/lib/libpangox-1.0.so.0 version [d55c756a93].
cannot compute difference between binary files
Added bin/.11/lib/libxcb-xlib.so.0 version [b7cbe8e250].
cannot compute difference between binary files
Modified cgisetup/models/pgdb.scm from [b49201d65c] to [2ad595b83f].
︙ | ︙ | |||
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 | ;; 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 pgdb)) (declare (uses configf)) ;; I don't know how to mix compilation units and modules, so no module here. ;; ;; (module pgdb ;; ( ;; open-pgdb ;; ) ;; ;; (import scheme) ;; (import data-structures) ;; (import chicken) (use typed-records (prefix dbi dbi:)) ;; given a configdat lookup the connection info and open the db ;; (define (pgdb:open configdat #!key (dbname #f)(dbispec #f)) (let ((pgconf (or dbispec (args:get-arg "-pgsync") (if configdat | > > | 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 | ;; 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 pgdb)) (declare (uses configf)) (declare (uses mtargs)) ;; I don't know how to mix compilation units and modules, so no module here. ;; ;; (module pgdb ;; ( ;; open-pgdb ;; ) ;; ;; (import scheme) ;; (import data-structures) ;; (import chicken) (use typed-records (prefix dbi dbi:)) (import (prefix mtargs args:)) ;; given a configdat lookup the connection info and open the db ;; (define (pgdb:open configdat #!key (dbname #f)(dbispec #f)) (let ((pgconf (or dbispec (args:get-arg "-pgsync") (if configdat |
︙ | ︙ | |||
175 176 177 178 179 180 181 | state=?,status=?,owner=?,event_time=?,comment=?,fail_count=?,pass_count=?,last_update=?,publish_time=? WHERE id=? and area_id=?;" state status owner event-time comment fail-count pass-count last_update publish-time run-id area-id )) ;; given all needed info create run record ;; (define (pgdb:insert-run dbh ttype-id target run-name state status owner event-time comment fail-count pass-count area-id last-update publish-time) | | | | 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 | state=?,status=?,owner=?,event_time=?,comment=?,fail_count=?,pass_count=?,last_update=?,publish_time=? WHERE id=? and area_id=?;" state status owner event-time comment fail-count pass-count last_update publish-time run-id area-id )) ;; given all needed info create run record ;; (define (pgdb:insert-run dbh ttype-id target run-name state status owner event-time comment fail-count pass-count area-id last-update publish-time) (dbi:exec dbh "INSERT INTO runs (ttype_id,target,run_name,state,status,owner,event_time,comment,fail_count,pass_count,area_id,last_update,publish_time) VALUES (?,?,?,?,?,?,?,?,?,?,?,?, ?);" ttype-id target run-name state status owner event-time comment fail-count pass-count area-id last-update publish-time)) ;;====================================================================== ;; T E S T - S T E P S ;;====================================================================== (define (pgdb:get-test-step-id dbh test-id stepname state) (dbi:get-one |
︙ | ︙ |
Modified chicken.makefile from [b07a513938] to [4ef647f9d5].
︙ | ︙ | |||
21 22 23 24 25 26 27 | # Chicken build #====================================================================== # CHICKEN_BIN_DIR=$(shell dirname $(shell which csi)) # if have csi on path use that, else use default # CSIPATH=$(shell which csi) # CKPATH=$(shell dirname $(shell dirname $(CSIPATH))) | | | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 | # Chicken build #====================================================================== # CHICKEN_BIN_DIR=$(shell dirname $(shell which csi)) # if have csi on path use that, else use default # CSIPATH=$(shell which csi) # CKPATH=$(shell dirname $(shell dirname $(CSIPATH))) sCHICKEN_PREFIX=$(or $(CKPATH),$(PREFIX)/bin/.$(ARCHSTR)) whatever : @echo "CHICKEN_PREFIX=$(CHICKEN_PREFIX)" tgz-$(USER)/postgresql-9.6.4.tar.gz : mkdir -p tgz-$(USER) wget -c https://ftp.postgresql.org/pub/source/v9.6.4/postgresql-9.6.4.tar.gz |
︙ | ︙ | |||
64 65 66 67 68 69 70 | cd tgz-$(USER)/nanomsg-1.0.0; mkdir build-$(USER); cd build-$(USER); cd tgz-$(USER)/nanomsg-1.0.0/build-$(USER); cmake ../ -DCMAKE_INSTALL_PREFIX=$(CHICKEN_PREFIX) cd tgz-$(USER)/nanomsg-1.0.0/build-$(USER); make; make install $(CHICKEN_PREFIX)/chicken-4.13.0/LICENSE : tgz-$(USER)/chicken-4.13.0.tar.gz mkdir -p build-$(USER)/eggs-installed cd build-$(USER);tar xf ../tgz-$(USER)/chicken-4.13.0.tar.gz | < | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 | cd tgz-$(USER)/nanomsg-1.0.0; mkdir build-$(USER); cd build-$(USER); cd tgz-$(USER)/nanomsg-1.0.0/build-$(USER); cmake ../ -DCMAKE_INSTALL_PREFIX=$(CHICKEN_PREFIX) cd tgz-$(USER)/nanomsg-1.0.0/build-$(USER); make; make install $(CHICKEN_PREFIX)/chicken-4.13.0/LICENSE : tgz-$(USER)/chicken-4.13.0.tar.gz mkdir -p build-$(USER)/eggs-installed cd build-$(USER);tar xf ../tgz-$(USER)/chicken-4.13.0.tar.gz tgz-$(USER)/opensrc.fossil : cd tgz-$(USER); fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil mkdir tgz-$(USER)/opensrc cd tgz-$(USER)/opensrc; fossil open --nested ../opensrc.fossil; fossil up; fossil uv sync $(CHICKEN_PREFIX)/lib/libiupweb.so : tgz-$(USER)/opensrc.fossil |
︙ | ︙ | |||
100 101 102 103 104 105 106 | cd tgz-$(USER); tar -xzvf ffcall.tar.gz cd tgz-$(USER)/ffcall; ./configure --prefix=$(CHICKEN_PREFIX) --enable-shared cd tgz-$(USER)/ffcall; make CC="gcc -fPIC"; make install $(CHICKEN_PREFIX)/bin/sqlite3 : build-$(USER)/sqlite-autoconf-3090200/configure cd build-$(USER)/sqlite-autoconf-3090200; ./configure --prefix=$(CHICKEN_PREFIX); make; make install | | | < | < < < < < < < | < | < < < < < < < < < < < < | | 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 | cd tgz-$(USER); tar -xzvf ffcall.tar.gz cd tgz-$(USER)/ffcall; ./configure --prefix=$(CHICKEN_PREFIX) --enable-shared cd tgz-$(USER)/ffcall; make CC="gcc -fPIC"; make install $(CHICKEN_PREFIX)/bin/sqlite3 : build-$(USER)/sqlite-autoconf-3090200/configure cd build-$(USER)/sqlite-autoconf-3090200; ./configure --prefix=$(CHICKEN_PREFIX); make; make install $(CHICKEN_PREFIX)/bin/csi : $(CHICKEN_PREFIX)/bin/sqlite3 $(CHICKEN_PREFIX)/lib/libiupweb.so $(CHICKEN_PREFIX)/chicken-4.13.0/LICENSE cd build-$(USER)/chicken-4.13.0;make PLATFORM=linux PREFIX=$(CHICKEN_PREFIX) cd build-$(USER)/chicken-4.13.0;make PLATFORM=linux PREFIX=$(CHICKEN_PREFIX) install ALL_CKBIN=chicken chicken-bind chicken-bug chicken-dump \ chicken-install chicken-profile chicken-sqlite3 chicken-status \ chicken-uninstall csc csi feathers nanocat sqlite3 vacuumdb logpro \ refdb CKBIN_WRAPPERS=$(addprefix $(PREFIX)/bin/,$(ALL_CKBIN)) $(PREFIX)/bin/% : $(CHICKEN_PREFIX)/bin/% $(CHICKEN_PREFIX)/bin/csi $(EGGSTARG2) utils/mk_wrapper_tool $(PREFIX) $* $(PREFIX)/bin/$* chmod a+x $(PREFIX)/bin/$* $(PREFIX)/bin : mkdir -p $(PREFIX)/bin $(CHICKEN_PREFIX)/bin chicken : $(PREFIX)/bin $(CHICKEN_PREFIX)/bin/csi binwrappers @echo "Fake target to build prefix chicken" binwrappers : $(CKBIN_WRAPPERS) postgresql.done : $(CHICKEN_PREFIX)/bin/pg_config CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib -L$(CHICKEN_PREFIX)/lib64" $(CHICKEN_PREFIX)/bin/chicken-install postgresql > postgresql.done nanomsg.done : $(CHICKEN_PREFIX)/lib/libnanomsg.so CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib -L$(CHICKEN_PREFIX)/lib64" $(CHICKEN_PREFIX)/bin/chicken-install nanomsg > nanomsg.done iup.done : $(CHICKEN_PREFIX)/lib/libcallback.a CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install -D no-library-checks -feature disable-iup-web -feature disable-iup-pplot -feature disable-iup-matrixex iup > iup.done canvas-draw.done : CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install -D no-library-checks canvas-draw > canvas-draw.done sqlite3.done : CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install sqlite3 > sqlite3.done sql-de-lite.done : CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install sql-de-lite > sql-de-lite.done dbi.done : postgresql.done sqlite3.done sql-de-lite.done CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install dbi > dbi.done |
︙ | ︙ |
Modified common.scm from [6aec6a8542] to [5c226366fd].
︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | ;; 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/>. ;;====================================================================== (use srfi-1 data-structures posix regex-case (prefix base64 base64:) format dot-locking csv-xml z3 udp ;; sql-de-lite hostinfo md5 message-digest typed-records directory-utils stack matchable regex posix (srfi 18) extras ;; tcp (prefix nanomsg nmsg:) (prefix sqlite3 sqlite3:) pkts (prefix dbi dbi:) ) | > > > > > > > > | < | > > > | > > > | | < < > | < > | | | > > > > > > > > | | > | 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 | ;; 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 common)) (declare (uses commonmod)) (declare (uses rmtmod)) (declare (uses debugprint)) (declare (uses mtargs)) (use srfi-1 data-structures posix regex-case (prefix base64 base64:) format dot-locking csv-xml z3 udp ;; sql-de-lite hostinfo md5 message-digest typed-records directory-utils stack matchable regex posix (srfi 18) extras ;; tcp (prefix nanomsg nmsg:) (prefix sqlite3 sqlite3:) pkts (prefix dbi dbi:) ) (use posix-extras pathname-expand files) (import commonmod debugprint rmtmod (prefix mtargs args:)) (define (remove-server-files directory-path) (let ((files (glob (string-append directory-path "/server*")))) (for-each delete-file* files))) (include "common_records.scm") (define (remove-files filespec) (let ((files (glob filespec))) (for-each delete-file* files))) (define (stop-the-train) (thread-start! (make-thread (lambda () (let loop () (if (and *toppath* (file-exists? (conc *toppath*"/stop-the-train"))) (let* ((msg (conc "ERROR: found file "*toppath*"/stop-the-train, exiting immediately"))) ;; yes, print to current-output-port AND *default-log-port*, annoying but necessary I think (print msg) (remove-server-files (conc *toppath* "/logs")) (debug:print 0 *default-log-port* msg) (remove-files (conc *toppath* "/logs/server*")) (remove-files (conc *toppath* "/.servinfo/*")) (remove-files (conc *toppath* "/.mtdb/*lock")) (exit 1))) (thread-sleep! 5) (loop)))))) ;; execute thunk, return value. If exception thrown, trap exception, return #f, and emit nonfatal condition note to *default-log-port* . ;; arguments - thunk, message (define (common:fail-safe thunk warning-message-on-exception) (handle-exceptions exn (begin |
︙ | ︙ | |||
127 128 129 130 131 132 133 | (define *toppath* #f) (define *already-seen-runconfig-info* #f) (define *test-meta-updated* (make-hash-table)) (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar ;; (define *alt-log-file* #f) ;; used by -log | | > < < < < | | | | | | < < < < | | | 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 | (define *toppath* #f) (define *already-seen-runconfig-info* #f) (define *test-meta-updated* (make-hash-table)) (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar ;; (define *alt-log-file* #f) ;; used by -log ;; (define *common:denoise* (make-hash-table)) ;; for low noise printing (define *default-log-port* (current-error-port)) (define *time-zero* (current-seconds)) ;; for the watchdog (define *on-exit-procs* '()) ;; add procs to this list to be executed on exit (define *default-area-tag* "local") ;; DATABASE ;; db access (define *db-last-access* (current-seconds)) ;; last db access, used in server ;; (define *db-write-access* #t) ;; db sync ;; (define *db-last-sync* 0) ;; last time the sync to megatest.db happened (define *db-sync-in-progress* #f) ;; if there is a sync in progress do not try to start another ;; (define *db-multi-sync-mutex* (make-mutex)) ;; protect access to *db-sync-in-progress*, *db-last-sync* ;; task db (define *task-db* #f) ;; (vector db path-to-db) (define *db-access-allowed* #t) ;; flag to allow access ;; (define *db-access-mutex* (make-mutex)) ;; moved to dbfile ;; (define *db-transaction-mutex* (make-mutex)) (define *db-cache-path* #f) ;; (define *db-with-db-mutex* (make-mutex)) (define *db-api-call-time* (make-hash-table)) ;; hash of command => (list of times) ;; SERVER (define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg (define *runremote* #f) ;; if set up for server communication this will hold <host port> ;; (define *max-cache-size* 0) (define *logged-in-clients* (make-hash-table)) (define *server-id* #f) (define *server-info* #f) ;; good candidate for easily convert to non-global (define *time-to-exit* #f) (define *run-id* #f) (define *server-kind-run* (make-hash-table)) (define *home-host* #f) ;; (define *total-non-write-delay* 0) (define *heartbeat-mutex* (make-mutex)) ;; (define *api-process-request-count* 0) ;; (define *max-api-process-requests* 0) (define *server-overloaded* #f) ;; client (define *rmt-mutex* (make-mutex)) ;; remote access calls mutex ;; RPC transport (define *rpc:listener* #f) |
︙ | ︙ | |||
195 196 197 198 199 200 201 | (define *run-info-cache* (make-hash-table)) ;; run info is stable, no need to reget (define *launch-setup-mutex* (make-mutex)) ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set (define *homehost-mutex* (make-mutex)) ;; Miscellaneous (define *triggers-mutex* (make-mutex)) ;; block overlapping processing of triggers | | < | 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 | (define *run-info-cache* (make-hash-table)) ;; run info is stable, no need to reget (define *launch-setup-mutex* (make-mutex)) ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set (define *homehost-mutex* (make-mutex)) ;; Miscellaneous (define *triggers-mutex* (make-mutex)) ;; block overlapping processing of triggers (define *numcpus-cache* (make-hash-table)) ;; this plugs a hole in posix-extras in recent chicken versions > 4.9) (let-values (( (chicken-release-number chicken-major-version) (apply values (map string->number (take (string-split (chicken-version) ".") |
︙ | ︙ | |||
223 224 225 226 227 228 229 230 231 232 233 | ((and (> (length argv) 2) (string-match "^(.*/csi|csi)$" (car argv)) (string-match "^-(s|ss|sx|script)$" (cadr argv))) (caddr argv)) (else (car argv)))) (fullpath (realpath this-script))) fullpath)) (define *common:this-exe-fullpath* (common:get-this-exe-fullpath)) (define *common:this-exe-dir* (pathname-directory *common:this-exe-fullpath*)) (define *common:this-exe-name* (pathname-strip-directory *common:this-exe-fullpath*)) | > > > < < < | < < | < < < < < | < | < < < < < < | 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 | ((and (> (length argv) 2) (string-match "^(.*/csi|csi)$" (car argv)) (string-match "^-(s|ss|sx|script)$" (cadr argv))) (caddr argv)) (else (car argv)))) (fullpath (realpath this-script))) fullpath)) ;;====================================================================== (define *common:this-exe-fullpath* (common:get-this-exe-fullpath)) (define *common:this-exe-dir* (pathname-directory *common:this-exe-fullpath*)) (define *common:this-exe-name* (pathname-strip-directory *common:this-exe-fullpath*)) (define (common:get-sync-lock-filepath) (let* ((tmp-area (common:make-tmpdir-name *toppath* "")) (lockfile (conc tmp-area "/megatest.db.lock"))) lockfile)) (define *common:logpro-exit-code->status-sym-alist* '( ( 0 . pass ) ( 1 . fail ) ( 2 . warn ) ( 3 . check ) ( 4 . waived ) |
︙ | ︙ | |||
292 293 294 295 296 297 298 299 | ((abort) "ABORT") ((skip) "SKIP") (else "FAIL"))) (define (common:logpro-exit-code->test-status exit-code) (status-sym->string (common:logpro-exit-code->status-sym exit-code))) (defstruct remote | > | > > > > > > > > | > > > > | < | > > > > > > > | 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 | ((abort) "ABORT") ((skip) "SKIP") (else "FAIL"))) (define (common:logpro-exit-code->test-status exit-code) (status-sym->string (common:logpro-exit-code->status-sym exit-code))) ;; (defstruct remote ;; transport to be used ;; http - use http-transport ;; http-read-cached - use http-transport for writes but in-mem cached for reads (rmode 'http) (hh-dat (let ((res (or (server:choose-server *toppath* 'homehost) (cons #f #f)))) (assert (pair? res)(conc "FATAL: hh-dat should be a pair, got "res)) res)) (server-url #f) ;; (server:check-if-running *toppath*) #f)) (server-id #f) (server-info #f) ;; (if *toppath* (server:check-if-running *toppath*) #f)) (last-server-check 0) ;; last time we checked to see if the server was alive (connect-time (current-seconds)) ;; when we first connected (last-access (current-seconds)) ;; last time we talked to server ;; (conndat #f) ;; iface port api-uri api-url api-req seconds server-id (server-timeout (server:expiration-timeout)) (force-server #f) (ro-mode #f) (ro-mode-checked #f) ;; flag that indicates we have checked for ro-mode ;; conndat stuff (iface #f) ;; TODO: Consolidate this data with server-url and server-info above (port #f) (api-url #f) (api-uri #f) (api-req #f)) ;; launching and hosts (defstruct host (reachable #f) (last-update 0) (last-used 0) (last-cpuload 1)) |
︙ | ︙ | |||
356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 | (define (common:get-full-version) (conc megatest-version "-" megatest-fossil-hash)) (define (common:version-signature) (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) ;; from metadat lookup MEGATEST_VERSION ;; (define (common:get-last-run-version) ;; RADT => How does this work in send-receive function??; assume it is the value saved in some DB (rmt:get-var "MEGATEST_VERSION")) (define (common:get-last-run-version-number) (string->number (substring (common:get-last-run-version) 0 6))) (define (common:set-last-run-version) (rmt:set-var "MEGATEST_VERSION" (common:version-signature))) ;; postive number if megatest version > db version ;; negative number if megatest version < db version (define (common:version-db-delta) | > > | > > > > > | | | | < < < < | > > > | | | > > | > > > > > > | | < | < | < | | 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 | (define (common:get-full-version) (conc megatest-version "-" megatest-fossil-hash)) (define (common:version-signature) (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) ;;====================================================================== ;; from metadat lookup MEGATEST_VERSION ;; (define (common:get-last-run-version) ;; RADT => How does this work in send-receive function??; assume it is the value saved in some DB (rmt:get-var "MEGATEST_VERSION")) (define (common:get-last-run-version-number) (string->number (substring (common:get-last-run-version) 0 6))) (define (common:set-last-run-version) (rmt:set-var "MEGATEST_VERSION" (common:version-signature))) ;;====================================================================== ;; postive number if megatest version > db version ;; negative number if megatest version < db version (define (common:version-db-delta) (- megatest-version (common:get-last-run-version-number))) (define (common:version-changed?) (not (equal? (common:get-last-run-version) (common:version-signature)))) ;; From 1.70 to 1.81, db's are compatible. ;; ;; BUG: This logic is almost certainly not quite correct. ;; (define (common:api-changed?) (let* ((megatest-major-version (substring (->string megatest-version) 0 4)) (run-major-version (substring (conc (common:get-last-run-version)) 0 4))) (and (not (member megatest-major-version '("1.81" "1.80"))) (not (equal? megatest-major-version run-major-version))))) ;;====================================================================== ;; Move me elsewhere ... ;; RADT => Why do we meed the version check here, this is called only if version misma ;; (define (common:cleanup-db dbstruct #!key (full #f)) (case (rmt:transport-mode) ((http) (apply db:multi-db-sync dbstruct 'schema 'killservers 'adj-target 'new2old '(dejunk) )) ((tcp nfs) (apply db:multi-db-sync dbstruct 'schema 'killservers 'adj-target 'new2old '(dejunk) ))) (if (common:api-changed?) (common:set-last-run-version))) (define (common:snapshot-file filepath #!key (subdir ".") ) (if (file-exists? filepath) (let* ((age-sec (lambda (file) (if (file-exists? file) |
︙ | ︙ | |||
485 486 487 488 489 490 491 | ;; copy <file>.days.gz <file>.weeks.gz ;; copy <file>.hrs.gz <file>.days.gz (when (>= (age-wks daysfile) 1) (copy daysfile wksfile) (copy hrsfile daysfile)) #t) #f)) | | < < < < < < < < < | < | | 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 | ;; copy <file>.days.gz <file>.weeks.gz ;; copy <file>.hrs.gz <file>.days.gz (when (>= (age-wks daysfile) 1) (copy daysfile wksfile) (copy hrsfile daysfile)) #t) #f)) ;;====================================================================== ;; Rotate logs, logic: ;; if > 500k and older than 1 week: ;; remove previous compressed log and compress this log ;; WARNING: This proc operates assuming that it is in the directory above the ;; logs directory you wish to log-rotate. ;; (define (common:rotate-logs) (let* ((all-files (make-hash-table)) (stats (make-hash-table)) (inc-stat (lambda (key) (hash-table-set! stats key (+ (hash-table-ref/default stats key 0) 1)))) (max-allowed (string->number (or (configf:lookup *configdat* "setup" "max-logfiles") "600")))) ;; name -> age (if (not (directory-exists? "logs"))(create-directory "logs")) (directory-fold (lambda (file rem) (handle-exceptions exn (begin (debug:print-info 2 *default-log-port* "unable to rotate log " file ", probably handled by another process, this is safe to ignore. exn=" exn) |
︙ | ︙ | |||
581 582 583 584 585 586 587 | (debug:print-info 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.") (handle-exceptions exn (debug:print-error 0 *default-log-port* "failed to remove " fullname ", exn=" exn) (delete-file* fullname))))) files) (debug:print-info 0 *default-log-port* "Deleted " (length files) " files from logs, keeping " max-allowed " files.")))))) | | > > | | | | | 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 | (debug:print-info 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.") (handle-exceptions exn (debug:print-error 0 *default-log-port* "failed to remove " fullname ", exn=" exn) (delete-file* fullname))))) files) (debug:print-info 0 *default-log-port* "Deleted " (length files) " files from logs, keeping " max-allowed " files.")))))) ;;====================================================================== ;; Force a megatest cleanup-db if version is changed and skip-version-check not specified ;; Do NOT check if not on homehost! ;; (define (common:exit-on-version-changed) (if (and *toppath* ;; do nothing if *toppath* not yet provided (common:on-homehost?)) (if (common:api-changed?) (let* ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config")) (dbfile (conc (get-environment-variable "MT_RUN_AREA_HOME") ".mtdb/main.db")) (read-only (not (file-write-access? dbfile))) (dbstruct (db:setup))) ;; (db:setup-db *dbstruct-dbs* *toppath* #f))) ;; #t))) (debug:print 0 *default-log-port* "WARNING: Version mismatch!\n" " expected: " (common:version-signature) "\n" " got: " (common:get-last-run-version)) (cond ((get-environment-variable "MT_SKIP_DB_MIGRATE") #t) ((and (common:file-exists? mtconf) (common:file-exists? dbfile) (not read-only) |
︙ | ︙ | |||
613 614 615 616 617 618 619 | (print-call-chain (current-error-port)) (exit 1)) (common:cleanup-db dbstruct))) ((not (common:file-exists? mtconf)) (debug:print 0 *default-log-port* " megatest.config does not exist in this area. Cannot proceed with megatest version migration.") (exit 1)) ((not (common:file-exists? dbfile)) | | | > | 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 | (print-call-chain (current-error-port)) (exit 1)) (common:cleanup-db dbstruct))) ((not (common:file-exists? mtconf)) (debug:print 0 *default-log-port* " megatest.config does not exist in this area. Cannot proceed with megatest version migration.") (exit 1)) ((not (common:file-exists? dbfile)) (debug:print 0 *default-log-port* " .mtdb/main.db does not exist in this area. Cannot proceed with megatest version migration.") (exit 1)) ((not (eq? (current-user-id)(file-owner mtconf))) (debug:print 0 *default-log-port* " You do not own .mtdb/main.db in this area. Cannot proceed with megatest version migration.") (exit 1)) (read-only (debug:print 0 *default-log-port* " You have read-only access to this area. Cannot proceed with megatest version migration.") (exit 1)) (else (debug:print 0 *default-log-port* " to switch versions you can run: \"megatest -cleanup-db\"") (exit 1))))))) ;;====================================================================== ;; (begin ;; (debug:print 0 *default-log-port* "ERROR: cannot migrate version unless on homehost. Exiting.") ;; (exit 1)))) ;;====================================================================== ;; S P A R S E A R R A Y S ;;====================================================================== |
︙ | ︙ | |||
696 697 698 699 700 701 702 | (if dat dat "")))) (define (common:alist-ref/default key alist default) (or (alist-ref key alist) default)) | > > | | | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 | (if dat dat "")))) (define (common:alist-ref/default key alist default) (or (alist-ref key alist) default)) ;; moved into commonmod ;; ;; (define (common:low-noise-print waitval . keys) ;; (let* ((key (string-intersperse (map conc keys) "-" )) ;; (lasttime (hash-table-ref/default *common:denoise* key 0)) ;; (currtime (current-seconds))) ;; (if (> (- currtime lasttime) waitval) ;; (begin ;; (hash-table-set! *common:denoise* key currtime) ;; #t) ;; #f))) (define (common:read-encoded-string instr) (handle-exceptions exn (handle-exceptions exn (begin (debug:print-error 0 *default-log-port* "received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) (print-call-chain (current-error-port)) #f) (read (open-input-string (base64:base64-decode instr)))) (read (open-input-string (z3:decode-buffer (base64:base64-decode instr)))))) ;;====================================================================== ;; S T A T E S A N D S T A T U S E S ;;====================================================================== ;; BBnote: *common:std-states* - dashboard filter control and test control state buttons defined here; used in set-fields-panel and dboard:make-controls (define *common:std-states* ;; for toggle buttons in dashboard |
︙ | ︙ | |||
791 792 793 794 795 796 797 798 799 800 801 802 803 804 | (define *common:dont-roll-up-states* '("DELETED" "REMOVING" "CLEANING" "ARCHIVE_REMOVING" )) ;; BBnote: *common:std-statuses* dashboard filter control and test control status buttons defined here; used in set-fields-panel and dboard:make-controls ;; note these statuses are sorted from better to worse. ;; This sort order is important to dcommon:status-compare3 and db:set-state-status-and-roll-up-items (define *common:std-statuses* '(;; (0 "DELETED") (1 "n/a") (2 "PASS") | > | 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 | (define *common:dont-roll-up-states* '("DELETED" "REMOVING" "CLEANING" "ARCHIVE_REMOVING" )) ;;====================================================================== ;; BBnote: *common:std-statuses* dashboard filter control and test control status buttons defined here; used in set-fields-panel and dboard:make-controls ;; note these statuses are sorted from better to worse. ;; This sort order is important to dcommon:status-compare3 and db:set-state-status-and-roll-up-items (define *common:std-statuses* '(;; (0 "DELETED") (1 "n/a") (2 "PASS") |
︙ | ︙ | |||
813 814 815 816 817 818 819 | (11 "PREQ_DISCARDED") (12 "ABORT"))) (define *common:ended-states* ;; states which indicate the test is stopped and will not proceed '("COMPLETED" "ARCHIVED" "KILLED" "KILLREQ" "STUCK" "INCOMPLETE" )) (define *common:badly-ended-states* ;; these roll up as CHECK, i.e. results need to be checked | | | > > | 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 | (11 "PREQ_DISCARDED") (12 "ABORT"))) (define *common:ended-states* ;; states which indicate the test is stopped and will not proceed '("COMPLETED" "ARCHIVED" "KILLED" "KILLREQ" "STUCK" "INCOMPLETE" )) (define *common:badly-ended-states* ;; these roll up as CHECK, i.e. results need to be checked '("KILLED" "KILLREQ" "STUCK" "INCOMPLETE" "DEAD" "CHECK")) (define *common:well-ended-states* ;; an item's prereq in this state allows item to proceed '("PASS" "WARN" "WAIVED" "SKIP")) ;; BBnote: *common:running-states* used from db:set-state-status-and-roll-up-items (define *common:running-states* ;; test is either running or can be run '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "STARTED")) (define *common:cant-run-states* ;; These are stopping conditions that prevent a test from being run '("COMPLETED" "KILLED" "UNKNOWN" "INCOMPLETE" "ARCHIVED")) (define *common:not-started-ok-statuses* ;; if not one of these statuses when in not_started state treat as dead '("n/a" "na" "PASS" "FAIL" "WARN" "CHECK" "WAIVED" "DEAD" "SKIP")) ;;====================================================================== ;; group tests into buckets corresponding to rollup ;;; Running, completed-pass, completed-non-pass + worst status, not started. ;; filter out ;(define (common:categorize-items-for-rollup in-tests) ; ( (define (common:special-sort items order comp) (let ((items-order (map reverse order)) (acomp (or comp >))) (sort items (lambda (a b) (let ((a-num (cadr (or (assoc a items-order) '(0 0)))) (b-num (cadr (or (assoc b items-order) '(0 0))))) (acomp a-num b-num)))))) ;;====================================================================== ;; ;; given a toplevel with currstate, currstatus apply state and status ;; ;; => (newstate . newstatus) ;; (define (common:apply-state-status currstate currstatus state status) ;; (let* ((cstate (string->symbol (string-downcase currstate))) ;; (cstatus (string->symbol (string-downcase currstatus))) ;; (sstate (string->symbol (string-downcase state))) ;; (sstatus (string->symbol (string-downcase status))) |
︙ | ︙ | |||
918 919 920 921 922 923 924 | (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") (pathname-file (or (if (string? *toppath* ) (pathname-file *toppath*) #f) | | > | 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 | (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") (pathname-file (or (if (string? *toppath* ) (pathname-file *toppath*) #f) (common:get-toppath #f))) "please-set-setup-area-name")) ;; (pathname-file (current-directory))))) ;;====================================================================== ;; safe getting of toppath (define (common:get-toppath areapath) (or *toppath* (if areapath (begin (set! *toppath* areapath) (setenv "MT_RUN_AREA_HOME" areapath) |
︙ | ︙ | |||
946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 | (if (equal? thepath "/") (begin (debug:print-error 0 *default-log-port* "Unable to find megatest home directory.") #f) (loop (pathname-directory thepath))))) )) (define common:get-area-name common:get-testsuite-name) (define (common:get-db-tmp-area . junk) (if *db-cache-path* *db-cache-path* (if *toppath* ;; common:get-create-writeable-dir (handle-exceptions exn (begin (debug:print-error 0 *default-log-port* "Couldn't create path to " *db-cache-path* ", exn=" exn) (exit 1)) | > > > > > | | | | > > > > > > > > < < < > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 | (if (equal? thepath "/") (begin (debug:print-error 0 *default-log-port* "Unable to find megatest home directory.") #f) (loop (pathname-directory thepath))))) )) ;;====================================================================== ;; redefine for future cleanup (converge on area-name, the more generic ;; (define common:get-area-name common:get-testsuite-name) (define (common:get-db-tmp-area . junk) (if *db-cache-path* *db-cache-path* (if *toppath* ;; common:get-create-writeable-dir (handle-exceptions exn (begin (debug:print-error 0 *default-log-port* "Couldn't create path to " *db-cache-path* ", exn=" exn) (exit 1)) (let* ((toppath (common:real-path *toppath*)) (tsname (common:get-testsuite-name)) (dbpath (common:get-create-writeable-dir (list (conc "/tmp/" (current-user-name) "/megatest_localdb/" tsname "/" (string-translate toppath "/" ".")) (conc "/tmp/" (current-process-id) ;; just in case we have an issue with the dir by own user name "/"(current-user-name) "/megatest_localdb/" tsname (string-translate toppath "/" ".")) )))) (set! *db-cache-path* dbpath) ;; ensure megatest area has .mtdb (let ((dbarea (conc *toppath* "/.mtdb"))) (if (not (file-exists? dbarea)) (create-directory dbarea))) ;; ensure tmp area has .mtdb (let ((dbarea (conc dbpath "/.mtdb"))) (if (not (file-exists? dbarea)) (create-directory dbarea))) dbpath)) #f))) (define (common:get-area-path-signature) (message-digest-string (md5-primitive) *toppath*)) ;;====================================================================== ;; E X I T H A N D L I N G ;;====================================================================== (define (common:run-sync?) (and *toppath* ;; gate if called before *toppath* is set (common:on-homehost?) (args:get-arg "-server"))) (define (std-signal-handler signum) ;; (signal-mask! signum) (set! *time-to-exit* #t) ;;(debug:print-info 13 *default-log-port* "got signal "signum) (debug:print-error 0 *default-log-port* "Received signal " signum " aaa exiting promptly") ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway |
︙ | ︙ | |||
1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 | ;; (set-signal-handler! signal/stop std-signal-handler) ;; ^Z NO, do NOT handle ^Z! ;;====================================================================== ;; M I S C U T I L S ;;====================================================================== ;; convert stuff to a number if possible (define (any->number val) (cond ((number? val) val) ((string? val) (string->number val)) ((symbol? val) (any->number (symbol->string val))) (else #f))) | > | 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 | ;; (set-signal-handler! signal/stop std-signal-handler) ;; ^Z NO, do NOT handle ^Z! ;;====================================================================== ;; M I S C U T I L S ;;====================================================================== ;;====================================================================== ;; convert stuff to a number if possible (define (any->number val) (cond ((number? val) val) ((string? val) (string->number val)) ((symbol? val) (any->number (symbol->string val))) (else #f))) |
︙ | ︙ | |||
1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 | (debug:print-info 10 *default-log-port* "patt " patt " modpatt " modpatt) (if (string-match (regexp modpatt) item) (set! res #t)))) (string-split patts ",")) res) #t)) ;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))' (define (common:get-disks #!key (configf #f)) (hash-table-ref/default (or configf (read-config "megatest.config" #f #t)) "disks" '("none" ""))) | > < < < < < < < < < < < < < < < > | 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 | (debug:print-info 10 *default-log-port* "patt " patt " modpatt " modpatt) (if (string-match (regexp modpatt) item) (set! res #t)))) (string-split patts ",")) res) #t)) ;;====================================================================== ;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))' (define (common:get-disks #!key (configf #f)) (hash-table-ref/default (or configf (read-config "megatest.config" #f #t)) "disks" '("none" ""))) (define (common:get-install-area) (let ((exe-path (car (argv)))) (if (common:file-exists? exe-path) (handle-exceptions exn #f (pathname-directory (pathname-directory (pathname-directory exe-path)))) #f))) ;;====================================================================== ;; return first path that can be created or already exists and is writable ;; (define (common:get-create-writeable-dir dirs) (if (null? dirs) #f (let loop ((hed (car dirs)) (tal (cdr dirs))) |
︙ | ︙ | |||
1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 | (if (and (string? res) (directory? res)) res (if (null? tal) #f (loop (car tal)(cdr tal)))))))) ;; return the youngest timestamp . filename ;; (define (common:get-youngest glob-list) (let ((all-files (apply append (map (lambda (patt) (handle-exceptions exn | > | 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 | (if (and (string? res) (directory? res)) res (if (null? tal) #f (loop (car tal)(cdr tal)))))))) ;;====================================================================== ;; return the youngest timestamp . filename ;; (define (common:get-youngest glob-list) (let ((all-files (apply append (map (lambda (patt) (handle-exceptions exn |
︙ | ︙ | |||
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 | (file-modification-time fname)))) (if (> curmod last-mod) (list curmod fname) res))) '(0 "n/a") all-files))) ;; use bash to expand a glob. Does NOT handle paths with spaces! ;; (define (common:bash-glob instr) (string-split (with-input-from-pipe (conc "/bin/bash -c \"echo " instr "\"") read-line))) ;;====================================================================== ;; Some safety net stuff ;;====================================================================== ;; return input if it is a list or return null (define (common:list-or-null inlst #!key (ovrd #f)(message #f)) (if (list? inlst) inlst (begin (if message (debug:print-error 0 *default-log-port* message)) (or ovrd '())))) ;;====================================================================== ;; T A R G E T S , S T A T E , S T A T U S , ;; R U N N A M E A N D T E S T P A T T ;;====================================================================== ;; (map print (map car (hash-table->alist (read-config "runconfigs.config" #f #t)))) ;; (define (common:get-runconfig-targets #!key (configf #f)) (let ((targs (sort (map car (hash-table->alist (or configf ;; NOTE: There is no value in using runconfig:read here. (read-config (conc *toppath* "/runconfigs.config") #f #t) (make-hash-table)))) string<?)) (target-patt (args:get-arg "-target"))) (if target-patt (filter (lambda (x) (patt-list-match x target-patt)) targs) targs))) ;; Lookup a value in runconfigs based on -reqtarg or -target ;; (define (runconfigs-get config var) (let ((targ (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET")))) (if targ (or (configf:lookup config targ var) (configf:lookup config "default" var)) | > > > > | 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 | (file-modification-time fname)))) (if (> curmod last-mod) (list curmod fname) res))) '(0 "n/a") all-files))) ;;====================================================================== ;; use bash to expand a glob. Does NOT handle paths with spaces! ;; (define (common:bash-glob instr) (string-split (with-input-from-pipe (conc "/bin/bash -c \"echo " instr "\"") read-line))) ;;====================================================================== ;; Some safety net stuff ;;====================================================================== ;;====================================================================== ;; return input if it is a list or return null (define (common:list-or-null inlst #!key (ovrd #f)(message #f)) (if (list? inlst) inlst (begin (if message (debug:print-error 0 *default-log-port* message)) (or ovrd '())))) ;;====================================================================== ;; T A R G E T S , S T A T E , S T A T U S , ;; R U N N A M E A N D T E S T P A T T ;;====================================================================== ;;====================================================================== ;; (map print (map car (hash-table->alist (read-config "runconfigs.config" #f #t)))) ;; (define (common:get-runconfig-targets #!key (configf #f)) (let ((targs (sort (map car (hash-table->alist (or configf ;; NOTE: There is no value in using runconfig:read here. (read-config (conc *toppath* "/runconfigs.config") #f #t) (make-hash-table)))) string<?)) (target-patt (args:get-arg "-target"))) (if target-patt (filter (lambda (x) (patt-list-match x target-patt)) targs) targs))) ;;====================================================================== ;; Lookup a value in runconfigs based on -reqtarg or -target ;; (define (runconfigs-get config var) (let ((targ (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET")))) (if targ (or (configf:lookup config targ var) (configf:lookup config "default" var)) |
︙ | ︙ | |||
1320 1321 1322 1323 1324 1325 1326 | ((and (equal? args-testpatt "%") rtestpatt) (debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt) rtestpatt) (else (debug:print-info 0 *default-log-port* "using testpatt " args-testpatt " rtestpatt:" rtestpatt) args-testpatt)))) | < < < < | | > | 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 | ((and (equal? args-testpatt "%") rtestpatt) (debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt) rtestpatt) (else (debug:print-info 0 *default-log-port* "using testpatt " args-testpatt " rtestpatt:" rtestpatt) args-testpatt)))) (define (common:false-on-exception thunk #!key (message #f)) (handle-exceptions exn (begin (if message (debug:print-info 0 *default-log-port* message)) #f) (thunk) )) (define (common:file-exists? path-string #!key (silent #f)) ;;;; TODO: catch permission denied exceptions and emit appropriate warnings. Might be able to get rid of with chicken 5? (common:false-on-exception (lambda () (file-exists? path-string)) message: (if (not silent) (conc "Unable to access path: " path-string) #f) )) (define (common:directory-exists? path-string) ;;;; TODO: catch permission denied exceptions and emit appropriate warnings (common:false-on-exception (lambda () (directory-exists? path-string)) message: (conc "Unable to access path: " path-string) )) ;;====================================================================== ;; does the directory exist and do we have write access? ;; ;; returns the directory or #f ;; (define (common:directory-writable? path-string) (handle-exceptions exn |
︙ | ︙ | |||
1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 | (if target (begin (debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements") (if exit-if-bad (exit 1)) #f) #f)))) ;; looking only (at least for now) at the MT_ variables craft the full testname ;; (define (common:get-full-test-name) (if (getenv "MT_TEST_NAME") (if (and (getenv "MT_ITEMPATH") (not (equal? (getenv "MT_ITEMPATH") ""))) (getenv "MT_TEST_NAME") (conc (getenv "MT_TEST_NAME") "/" (getenv "MT_ITEMPATH"))) #f)) ;; logic for getting homehost. Returns (host . at-home) ;; IF *toppath* is not set, wait up to five seconds trying every two seconds ;; (this is to accomodate the watchdog) ;; | > > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | > | > | 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 | (if target (begin (debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements") (if exit-if-bad (exit 1)) #f) #f)))) ;;====================================================================== ;; looking only (at least for now) at the MT_ variables craft the full testname ;; (define (common:get-full-test-name) (if (getenv "MT_TEST_NAME") (if (and (getenv "MT_ITEMPATH") (not (equal? (getenv "MT_ITEMPATH") ""))) (getenv "MT_TEST_NAME") (conc (getenv "MT_TEST_NAME") "/" (getenv "MT_ITEMPATH"))) #f)) ;;====================================================================== ;; logic for getting homehost. Returns (host . at-home) ;; IF *toppath* is not set, wait up to five seconds trying every two seconds ;; (this is to accomodate the watchdog) ;; ;;====================================================================== ;; do we honor the caches of the config files? ;; (define (common:use-cache?) (let ((res #t)) ;; priority by order of evaluation (if *configdat* ;; sillyness here. can't use setup/use-cache to know if we can use the cached files! (if (equal? (configf:lookup *configdat* "setup" "use-cache") "no") (set! res #f) (if (equal? (configf:lookup *configdat* "setup" "use-cache") "yes") (set! res #t)))) (if (args:get-arg "-no-cache")(set! res #f)) ;; overrides setting in "setup" (if (getenv "MT_USE_CACHE") (if (equal? (getenv "MT_USE_CACHE") "yes") (set! res #t) (if (equal? (getenv "MT_USE_CACHE") "no") (set! res #f)))) ;; overrides -no-cache switch res)) ;;====================================================================== ;; force use of server? ;; (define (common:force-server?) (let* ((force-setting (configf:lookup *configdat* "server" "force")) (force-type (if force-setting (string->symbol force-setting) #f)) (force-result (case force-type ((#f) #f) ((always) #t) ((test) (if (args:get-arg "-execute") ;; we are in a test #t #f)) (else (debug:print 0 *default-log-port* "ERROR: Bad server force setting " force-setting ", forcing server.") #t)))) ;; default to requiring server (if force-result (begin (debug:print-info 0 *default-log-port* "ATTENTION! Forcing use of server, force setting is \"" force-setting "\".") #t) #f))) ;;====================================================================== ;; M I S C L I S T S ;;====================================================================== ;;====================================================================== ;; items in lista are matched value and position in listb ;; return the remaining items in listb or #f ;; (define (common:list-is-sublist lista listb) (if (null? lista) listb ;; all items in listb are "remaining" (if (> (length lista)(length listb)) |
︙ | ︙ | |||
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 | (loop (car tala) (cdr tala) (car talb) (cdr talb))) #f))))) ;; Needed for long lists to be sorted where (apply max ... ) dies ;; (define (common:max inlst) (let loop ((max-val (car inlst)) (hed (car inlst)) (tal (cdr inlst))) (if (not (null? tal)) (loop (max hed max-val) (car tal) (cdr tal)) (max hed max-val)))) ;; get min or max, use > for max and < for min, this works around the limits on apply ;; (define (common:min-max comp lst) (if (null? lst) #f ;; better than an exception for my needs (fold (lambda (a b) (if (comp a b) a b)) (car lst) lst))) ;; get min or max, use > for max and < for min, this works around the limits on apply ;; (define (common:sum lst) (if (null? lst) 0 (fold (lambda (a b) (+ a b)) (car lst) lst))) ;; path list to hash-table tree ;; ((a b c)(a b d)(e b c)) => ((a (b (d) (c))) (e (b (c)))) ;; (define (common:list->htree lst) (let ((resh (make-hash-table))) (for-each (lambda (inlst) | > > > > | 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 | (loop (car tala) (cdr tala) (car talb) (cdr talb))) #f))))) ;;====================================================================== ;; Needed for long lists to be sorted where (apply max ... ) dies ;; (define (common:max inlst) (let loop ((max-val (car inlst)) (hed (car inlst)) (tal (cdr inlst))) (if (not (null? tal)) (loop (max hed max-val) (car tal) (cdr tal)) (max hed max-val)))) ;;====================================================================== ;; get min or max, use > for max and < for min, this works around the limits on apply ;; (define (common:min-max comp lst) (if (null? lst) #f ;; better than an exception for my needs (fold (lambda (a b) (if (comp a b) a b)) (car lst) lst))) ;;====================================================================== ;; get min or max, use > for max and < for min, this works around the limits on apply ;; (define (common:sum lst) (if (null? lst) 0 (fold (lambda (a b) (+ a b)) (car lst) lst))) ;;====================================================================== ;; path list to hash-table tree ;; ((a b c)(a b d)(e b c)) => ((a (b (d) (c))) (e (b (c)))) ;; (define (common:list->htree lst) (let ((resh (make-hash-table))) (for-each (lambda (inlst) |
︙ | ︙ | |||
1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 | (cdr tal))) (begin (hash-table-set! ht hed (make-hash-table)) (loop ht hed tal))))) lst) resh)) ;; hash-table tree to html list tree ;; ;; tipfunc takes two parameters: y the tip value and path the path to that point ;; (define (common:htree->html ht path tipfunc) (let ((datlist (sort (hash-table->alist ht) (lambda (a b) | > | 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 | (cdr tal))) (begin (hash-table-set! ht hed (make-hash-table)) (loop ht hed tal))))) lst) resh)) ;;====================================================================== ;; hash-table tree to html list tree ;; ;; tipfunc takes two parameters: y the tip value and path the path to that point ;; (define (common:htree->html ht path tipfunc) (let ((datlist (sort (hash-table->alist ht) (lambda (a b) |
︙ | ︙ | |||
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 | (s:li (tipfunc y newpath)) (s:li (list levelname (common:htree->html y newpath tipfunc)))))) datlist))))) ;; hash-table tree to alist tree ;; (define (common:htree->atree ht) (map (lambda (x) (cons (car x) (let ((y (cdr x))) (if (hash-table? y) (common:htree->atree y) y)))) (hash-table->alist ht))) ;;====================================================================== ;; M U N G E D A T A I N T O N I C E F O R M S ;;====================================================================== ;; Generate an index for a sparse list of key values ;; ( (rowname1 colname1 val1)(rowname2 colname2 val2) ) ;; ;; => ;; ;; ( (rowname1 0)(rowname2 1)) ;; rownames -> num ;; (colname1 0)(colname2 1)) ) ;; colnames -> num | > > | 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 | (s:li (tipfunc y newpath)) (s:li (list levelname (common:htree->html y newpath tipfunc)))))) datlist))))) ;;====================================================================== ;; hash-table tree to alist tree ;; (define (common:htree->atree ht) (map (lambda (x) (cons (car x) (let ((y (cdr x))) (if (hash-table? y) (common:htree->atree y) y)))) (hash-table->alist ht))) ;;====================================================================== ;; M U N G E D A T A I N T O N I C E F O R M S ;;====================================================================== ;;====================================================================== ;; Generate an index for a sparse list of key values ;; ( (rowname1 colname1 val1)(rowname2 colname2 val2) ) ;; ;; => ;; ;; ( (rowname1 0)(rowname2 1)) ;; rownames -> num ;; (colname1 0)(colname2 1)) ) ;; colnames -> num |
︙ | ︙ | |||
1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 | (cdr tal) new-rownames new-colnames (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) | > > | 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 | (cdr tal) new-rownames new-colnames (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) |
︙ | ︙ | |||
1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 | 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 ;; (define (common:lazy-modification-time fpath) (handle-exceptions exn (begin | > | > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 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 ;; (define (common:lazy-modification-time fpath) (handle-exceptions exn (begin (debug:print 2 *default-log-port* "Failed to get modification time for " fpath ", treating it as zero. exn=" exn) 0) (if (file-exists? fpath) (file-modification-time fpath) 0))) ;;====================================================================== ;; find timestamp of newest file associated with a sqlite db file (define (common:lazy-sqlite-db-modification-time fpath) (let* ((glob-list (handle-exceptions exn (begin (debug:print 0 *default-log-port* "Failed to glob " fpath "*, exn=" exn) `(,(conc "/no/such/file, message: " ((condition-property-accessor 'exn 'message) exn)))) (glob (conc fpath "*")))) (file-list (if (eq? 0 (length glob-list)) '("/no/such/file") glob-list))) (apply max (map common:lazy-modification-time file-list)))) ;;====================================================================== ;; return a nice clean pathname made absolute (define (common:nice-path dir) (let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir))) (if match ;; using ~ for home? (common:nice-path (conc (common:read-link-f (cadr match)) "/" (caddr match))) (normalize-pathname (if (absolute-pathname? dir) dir (conc (current-directory) "/" dir)))))) ;;====================================================================== ;; make "nice-path" available in config files and the repl (define nice-path common:nice-path) (define (common:read-link-f path) (handle-exceptions exn (begin (debug:print-error 0 *default-log-port* "command \"/bin/readlink -f " path "\" failed. exn=" exn) path) ;; just give up (with-input-from-pipe (conc "/bin/readlink -f " path) (lambda () (read-line))))) ;; for reasons I don't understand multiple calls to real-path in parallel threads ;; must be protected by mutexes ;; (define (common:real-path inpath) ;; (process:cmd-run-with-stderr->list "readlink" "-f" inpath)) ;; cmd . params) ;; (let-values ;; (((inp oup pid) (process "readlink" (list "-f" inpath)))) ;; (with-input-from-port inp ;; (let loop ((inl (read-line)) ;; (res #f)) ;; (print "inl=" inl) ;; (if (eof-object? inl) ;; (begin ;; (close-input-port inp) ;; (close-output-port oup) ;; ;; (process-wait pid) ;; res) ;; (loop (read-line) inl)))))) (with-input-from-pipe (conc "readlink -f " inpath) read-line)) ;;====================================================================== ;; returns *effective load* (not normalized) ;; (define (common:get-intercept onemin fivemin) (if (< onemin fivemin) ;; load is decreasing, just use the onemin load onemin (let* ((load-change (- onemin fivemin)) (tchange (- 300 60))) (max (+ onemin (* 60 (/ load-change tchange))) 0)))) ;;====================================================================== ;; calculate a delay number based on a droop curve ;; inputs are: ;; - load-in, load as from uptime, NOT normalized ;; - numcpus, number of cpus, ideally use the real cpus, not threads ;; (define (common:get-delay load-in numcpus) (let* ((ratio (/ load-in numcpus)) |
︙ | ︙ | |||
1795 1796 1797 1798 1799 1800 1801 | ((r1 r2 s1 s2) (debug:print 3 *default-log-port* "Using params r1=" r1 " r2=" r2 " s1=" s1 " s2=" s2) (min (max (/ (expt r1 (* r2 s2 ratio)) s1) 0) 30)) (else (debug:print 0 *default-log-port* "BAD exp-params, should be \"r1 r2 s1 s2\" but got " paramstr) 30))))) | > > | | | | | | | > > > | | | | 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 | ((r1 r2 s1 s2) (debug:print 3 *default-log-port* "Using params r1=" r1 " r2=" r2 " s1=" s1 " s2=" s2) (min (max (/ (expt r1 (* r2 s2 ratio)) s1) 0) 30)) (else (debug:print 0 *default-log-port* "BAD exp-params, should be \"r1 r2 s1 s2\" but got " paramstr) 30))))) ;; -mrw- this appears to not be used ;; ;; (define (common:print-delay-table) ;; (let loop ((x 0)) ;; (print x "," (common:get-delay x 1)) ;; (if (< x 2) ;; (loop (+ x 0.1))))) ;; (define (get-cpu-load #!key (remote-host #f)) ;; (car (common:get-cpu-load remote-host))) ;;====================================================================== ;; (let* ((load-res (process:cmd-run->list "uptime")) ;; (load-rx (regexp "load average:\\s+(\\d+)")) ;; (cpu-load #f)) ;; (for-each (lambda (l) ;; (let ((match (string-search load-rx l))) ;; (if match ;; (let ((newval (string->number (cadr match)))) ;; (if (number? newval) ;; (set! cpu-load newval)))))) ;; (car load-res)) ;; cpu-load)) ;;====================================================================== ;; get values from cached info from dropping file in .sysdata dir ;; e.g. key is host and dtype is normalized-load ;; (define (common:get-cached-info key dtype #!key (age 10)) (if *toppath* (let* ((fullpath (conc *toppath* "/.sysdata/" key "-" dtype ".log")) (delfile (lambda (exn) (debug:print-info 2 *default-log-port* " removing bad file " fullpath ", exn=" exn) (delete-file* fullpath) #f))) (if (and (file-exists? fullpath) (file-read-access? fullpath)) (handle-exceptions exn (begin |
︙ | ︙ | |||
1844 1845 1846 1847 1848 1849 1850 | (debug:print 1 *default-log-port* "Failed to read mod time on file " fullpath ", using 0, exn=" exn) 0) (file-change-time fullpath))))) (if (< real-age age) (handle-exceptions exn | | | | > | | | > | | < | | > > > | > < | < > | 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 | (debug:print 1 *default-log-port* "Failed to read mod time on file " fullpath ", using 0, exn=" exn) 0) (file-change-time fullpath))))) (if (< real-age age) (handle-exceptions exn (delfile exn) (let* ((res (with-input-from-file fullpath read))) (if (eof-object? res) (begin (delfile "n/a") #f) res))) (begin (debug:print-info 2 *default-log-port* "file " fullpath " is too old (" real-age" seconds) to trust, skipping reading it") #f)))) (begin (debug:print 2 *default-log-port* "not reading file " fullpath) #f))) #f)) (define (common:write-cached-info key dtype dat) (if *toppath* (let* ((fulldir (conc *toppath* "/.sysdata")) (fullpath (conc fulldir "/" key "-" dtype ".log"))) (if (not (file-exists? fulldir))(create-directory fulldir #t)) (handle-exceptions exn (begin (debug:print 0 *default-log-port* "failed to write file " fullpath ", exn=" exn) #f) (with-output-to-file fullpath (lambda ()(pp dat))))) #f)) (define (common:raw-get-remote-host-load remote-host) (let* ((inp #f)) (handle-exceptions exn (begin (close-input-pipe inp) (debug:print 0 *default-log-port* "failed to ssh to " remote-host " and get loadavg. exn=" exn) #f) ;; more specific handling of errors needed (set! inp (open-input-pipe (conc "ssh " remote-host " cat /proc/loadavg"))) (let ((res (list (read inp)(read inp)(read inp)))) (close-input-pipe inp) res)))) ;;====================================================================== ;; get cpu load by reading from /proc/loadavg, return all three values ;; (define (common:get-cpu-load remote-host) (handle-exceptions exn (begin (debug:print 0 *default-log-port* "failed to ssh or read loadavg from host " remote-host ", exn=" exn) '(-99 -99 -99)) (let* ((actual-hostname (or remote-host (get-host-name) "localhost"))) (or (common:get-cached-info actual-hostname "cpu-load") (let ((result (if (and remote-host (not (equal? remote-host (get-host-name)))) (map (lambda (res) (if (eof-object? res) 9e99 res)) (common:raw-get-remote-host-load remote-host)) (with-input-from-file "/proc/loadavg" (lambda ()(list (read)(read)(read))))))) (match result ((l1 l2 l3) (if (and (number? l1) (number? l2) (number? l3)) (begin (common:write-cached-info actual-hostname "cpu-load" result) result) '(-1 -1 -1))) ;; -1 is bad result (else '(-2 -2 -2)))))))) ;;====================================================================== ;; 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 (common:get-normalized-cpu-load remote-host) (let ((res (common:get-normalized-cpu-load-raw remote-host)) (default `((adj-proc-load . 2) ;; there is no right answer |
︙ | ︙ | |||
1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 | (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 (common:get-normalized-cpu-load-raw remote-host) (let* ((actual-host (or remote-host (get-host-name)))) ;; #f is localhost (or (common:get-cached-info actual-host "normalized-load") (let ((data (if remote-host | > > > > > > < | < | 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 | (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 (common:ssh-get-loadavg remote-host) (let ((inp (open-input-pipe (conc "ssh " remote-host " \"cat /proc/loadavg;cat /proc/cpuinfo;echo end\"")))) (let* ((res (read-lines inp))) (close-input-pipe inp) res))) (define (common:get-normalized-cpu-load-raw remote-host) (let* ((actual-host (or remote-host (get-host-name)))) ;; #f is localhost (or (common:get-cached-info actual-host "normalized-load") (let ((data (if remote-host (common:ssh-get-loadavg remote-host) (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+.*$")) |
︙ | ︙ | |||
1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 | ;; (print "NO MATCH: " hed) (loop (car tal)(cdr tal) loads proc-num phys-num core-num))))))))))) (define (common:unix-ping hostname) (let ((res (system (conc "ping -c 1 " hostname " > /dev/null")))) (eq? res 0))) ;; ideally put all this info into the db, no need to preserve it across moving homehost ;; ;; return list of ;; ( reachable? cpuload update-time ) (define (common:get-host-info hostname) (let* ((loadinfo (rmt:get-latest-host-load hostname)) ;; if this host happens to have been recently used by a test reuse the load data (load (car loadinfo)) | > | 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 | ;; (print "NO MATCH: " hed) (loop (car tal)(cdr tal) loads proc-num phys-num core-num))))))))))) (define (common:unix-ping hostname) (let ((res (system (conc "ping -c 1 " hostname " > /dev/null")))) (eq? res 0))) ;;====================================================================== ;; ideally put all this info into the db, no need to preserve it across moving homehost ;; ;; return list of ;; ( reachable? cpuload update-time ) (define (common:get-host-info hostname) (let* ((loadinfo (rmt:get-latest-host-load hostname)) ;; if this host happens to have been recently used by a test reuse the load data (load (car loadinfo)) |
︙ | ︙ | |||
2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 | (list #t (current-seconds) (alist-ref 'adj-core-load (common:get-normalized-cpu-load hostname)))) ;; this is cheaper than you might think. get-normalized-cpu-load is cached for up to 5 seconds (else (list #f 0 -1) ;; bad host, don't use! )))) ;; see defstruct host at top of file. ;; host: reachable last-update last-used last-cpuload ;; (define (common:update-host-loads-table hosts-raw) (let* ((hosts (filter (lambda (x) (string-match (regexp "^\\S+$") x)) hosts-raw))) | > | 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 | (list #t (current-seconds) (alist-ref 'adj-core-load (common:get-normalized-cpu-load hostname)))) ;; this is cheaper than you might think. get-normalized-cpu-load is cached for up to 5 seconds (else (list #f 0 -1) ;; bad host, don't use! )))) ;;====================================================================== ;; see defstruct host at top of file. ;; host: reachable last-update last-used last-cpuload ;; (define (common:update-host-loads-table hosts-raw) (let* ((hosts (filter (lambda (x) (string-match (regexp "^\\S+$") x)) hosts-raw))) |
︙ | ︙ | |||
2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 | (last-reached-time (cadr host-info)) (load (caddr host-info))) (host-reachable-set! rec is-reachable) (host-last-update-set! rec last-reached-time) (host-last-cpuload-set! rec load))) hosts))) ;; go through the hosts from least recently used to most recently used, pick the first that meets the load criteral from the ;; [host-rules] section. ;; (define (common:get-least-loaded-host hosts-raw host-type configdat) (let* ((rdat (configf:lookup configdat "host-rules" host-type)) (rules (common:val->alist (or rdat "") convert: #t)) ;; maxnload, maxnjobs, maxjobrate (maxnload (common:alist-ref/default 'maxnload rules 1.5)) ;; max normalized load | > | 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 | (last-reached-time (cadr host-info)) (load (caddr host-info))) (host-reachable-set! rec is-reachable) (host-last-update-set! rec last-reached-time) (host-last-cpuload-set! rec load))) hosts))) ;;====================================================================== ;; go through the hosts from least recently used to most recently used, pick the first that meets the load criteral from the ;; [host-rules] section. ;; (define (common:get-least-loaded-host hosts-raw host-type configdat) (let* ((rdat (configf:lookup configdat "host-rules" host-type)) (rules (common:val->alist (or rdat "") convert: #t)) ;; maxnload, maxnjobs, maxjobrate (maxnload (common:alist-ref/default 'maxnload rules 1.5)) ;; max normalized load |
︙ | ︙ | |||
2117 2118 2119 2120 2121 2122 2123 | (begin ;; found a host, return it (debug:print 0 *default-log-port* "INFO: Found host: " new-best " load: " load " last-used: " delta " seconds ago, with job-rate: " job-rate) (host-last-used-set! rec curr-time) new-best) (if (null? tal) #f (loop (car tal)(cdr tal) best-host))))))))) (define (common:wait-for-homehost-load maxnormload msg) | > > > > > > > > > | | | | | > > | < | > | | > > | | | < | | | < < < < | < | | | | | | | | | | | | | | | > > | 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 | (begin ;; found a host, return it (debug:print 0 *default-log-port* "INFO: Found host: " new-best " load: " load " last-used: " delta " seconds ago, with job-rate: " job-rate) (host-last-used-set! rec curr-time) new-best) (if (null? tal) #f (loop (car tal)(cdr tal) best-host))))))))) (define (common:wait-for-homehost-load maxnormload msg) (let loop ((start-time (current-seconds))) ;; we saw some instances of this being called before *toppath* was set. This might be an early setup race. This delay should help but it is impossible to test... (if (not *toppath*) (begin (debug:print 0 *default-log-port* "ERROR: common:wait-for-homehost-load called before *toppath* set.") (thread-sleep! 30) (if (< (- (current-seconds) start-time) 300) (loop start-time))))) (case (rmt:transport-mode) ((http) (let* ((hh-dat (if (common:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local. #f (server:choose-server *toppath* 'homehost))) (hh (if hh-dat (car hh-dat) #f))) (common:wait-for-normalized-load maxnormload msg hh))) (else (common:wait-for-normalized-load maxnormload msg (get-host-name))))) (define (common:get-num-cpus remote-host) (let* ((actual-host (or remote-host (get-host-name)))) ;; hosts had better not be changing the number of cpus too often! (or (hash-table-ref/default *numcpus-cache* actual-host #f) (let* ((numcpus (or (common:get-cached-info actual-host "num-cpus" age: (+ 2592000 (random 3600))) (let* ((proc (lambda () (let loop ((numcpu 0) (inl (read-line))) (if (eof-object? inl) (if (> numcpu 0) numcpu #f) ;; if zero return #f so caller knows that things are not working (loop (if (string-match "^processor\\s+:\\s+\\d+$" inl) (+ numcpu 1) numcpu) (read-line)))))) (result (if (and remote-host (not (equal? remote-host (get-host-name)))) (common:generic-ssh (conc "ssh " remote-host " cat /proc/cpuinfo") proc -1) (with-input-from-file "/proc/cpuinfo" proc)))) (if (and (number? result) (> result 0)) (common:write-cached-info actual-host "num-cpus" result)) result)))) (hash-table-set! *numcpus-cache* actual-host numcpus) numcpus)))) ;;====================================================================== ;; wait for normalized cpu load to drop below maxload ;; (define (common:wait-for-normalized-load maxnormload msg remote-host #!optional (rem-tries 5)) (let ((num-cpus (common:get-num-cpus remote-host))) (if num-cpus (common:wait-for-cpuload maxnormload num-cpus 15 msg: msg remote-host: remote-host) (begin (thread-sleep! (random 60)) ;; we failed to get num cpus. wait a bit and try again (if (> rem-tries 0) (common:wait-for-normalized-load maxnormload msg remote-host (- rem-tries 1)) #f))))) ;;====================================================================== ;; DO NOT CALL THIS DIRECTLY. It is called from common:wait-for-normalized-load ;; count - count down to zero, at some point we'd give up if the load never drops ;; num-tries - count down to zero number tries to get numcpus ;; (define (common:wait-for-cpuload maxnormload numcpus-in #!key (count 1000) (msg #f)(remote-host #f)(num-tries 5)) (let* ((loadavg (common:get-cpu-load remote-host)) ;; not possible to have zero. If we get 1, it's possible that we got the previous default, and we should check again (numcpus (if (<= 1 numcpus-in) (common:get-num-cpus remote-host) numcpus-in)) (first (car loadavg)) (next (cadr loadavg)) (adjmaxload (* maxnormload (max 1 numcpus))) ;; possible bug where numcpus (or could be maxload) is zero, crude ;; fallback is to at least use 1 ;; effective load accounts for load jumps, this should elminate all the first-next-avg, adjwait, load-jump-limit ;; etc. (effective-load (common:get-intercept first next)) (recommended-delay (common:get-delay effective-load numcpus)) (effective-host (or remote-host "localhost")) (normalized-effective-load (/ effective-load numcpus)) (will-wait (> normalized-effective-load maxnormload))) (if (and will-wait (> recommended-delay 1)) (let* ((actual-delay (min recommended-delay 30))) (if (common:low-noise-print 30 (conc (round actual-delay) "-safe-load")) (debug:print-info 0 *default-log-port* "Load control, delaying " actual-delay " seconds to maintain safe load. current normalized effective load is " normalized-effective-load". maxnormload = " maxnormload " numcpus = " numcpus " loadavg = " loadavg " effective-load = " effective-load)) (thread-sleep! actual-delay))) (cond ;; bad data, try again to get the data ((not will-wait) (if (common:low-noise-print 3600 (conc (round normalized-effective-load) "-load-acceptable-" effective-host)) (debug:print 0 *default-log-port* "Effective load on " effective-host " is acceptable at " effective-load " continuing."))) ((and (< first 0) ;; this indicates the loadavg data is bad - machine may not be reachable (> num-tries 0)) (debug:print 0 *default-log-port* "WARNING: received bad data from get-cpu-load " first ", we'll sleep 10s and try " num-tries " more times.") (thread-sleep! 10) (common:wait-for-cpuload maxnormload numcpus-in count: count remote-host: remote-host num-tries: (- num-tries 1))) ;; need to wait for load to drop ((and will-wait ;; (> first adjmaxload) (> count 0)) (debug:print-info 0 *default-log-port* "Delaying 15" ;; adjwait " seconds due to normalized effective load " normalized-effective-load ;; first " exceeding max of " adjmaxload |
︙ | ︙ | |||
2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 | (if (> num-tries 0) ;; should be "num-tries-left". (if (common:low-noise-print 30 (conc (round effective-load) "-load-acceptable-" effective-host)) (debug:print 0 *default-log-port* "Load on " effective-host " is acceptable at effective normalized load of " effective-normalized-load " continuing.")) (debug:print 0 *default-log-port* "Load on " effective-host ", " first" could not be retrieved. Giving up and continuing.")))))) ;; DO NOT CALL THIS DIRECTLY. It is called from common:wait-for-normalized-load ;; ;; (define (common:wait-for-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f)(force-maxload #f)(num-tries 5)) ;; (let* ((loadavg (common:get-cpu-load remote-host)) ;; (numcpus (if (<= 1 numcpus-in) ;; not possible to have zero. If we get 1, it's possible that we got the previous default, and we should check again ;; (common:get-num-cpus remote-host) ;; numcpus-in)) | > | 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 | (if (> num-tries 0) ;; should be "num-tries-left". (if (common:low-noise-print 30 (conc (round effective-load) "-load-acceptable-" effective-host)) (debug:print 0 *default-log-port* "Load on " effective-host " is acceptable at effective normalized load of " effective-normalized-load " continuing.")) (debug:print 0 *default-log-port* "Load on " effective-host ", " first" could not be retrieved. Giving up and continuing.")))))) ;;====================================================================== ;; DO NOT CALL THIS DIRECTLY. It is called from common:wait-for-normalized-load ;; ;; (define (common:wait-for-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f)(force-maxload #f)(num-tries 5)) ;; (let* ((loadavg (common:get-cpu-load remote-host)) ;; (numcpus (if (<= 1 numcpus-in) ;; not possible to have zero. If we get 1, it's possible that we got the previous default, and we should check again ;; (common:get-num-cpus remote-host) ;; numcpus-in)) |
︙ | ︙ | |||
2331 2332 2333 2334 2335 2336 2337 | (define (get-uname . params) (let* ((uname-res (process:cmd-run->list (conc "uname " (if (null? params) "-a" (car params))))) (uname #f)) (if (null? (car uname-res)) "unknown" (caar uname-res)))) | < < < < < < < < < < < < < < < < < < < < > | 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 | (define (get-uname . params) (let* ((uname-res (process:cmd-run->list (conc "uname " (if (null? params) "-a" (car params))))) (uname #f)) (if (null? (car uname-res)) "unknown" (caar uname-res)))) ;;====================================================================== ;; D I S K S P A C E ;;====================================================================== (define (common:get-disk-space-used fpath) (with-input-from-pipe (conc "/usr/bin/du -s " fpath) read)) ;;====================================================================== ;; given path get free space, allows override in [setup] ;; with free-space-script /path/to/some/script.sh ;; (define (get-df path) (if (configf:lookup *configdat* "setup" "free-space-script") (with-input-from-pipe (conc (configf:lookup *configdat* "setup" "free-space-script") " " path) |
︙ | ︙ | |||
2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 | (get-df dirpath) 0))) (list (> dbspace required) dbspace required dirpath))) ;; check space in dbdir and in megatest dir ;; returns: ok/not dbspace required-space ;; (define (common:check-db-dir-space) (let* ((required (string->number ;; default is 1GB (or actually a billion bytes) This is the number of 1 kB blocks. (or (configf:lookup *configdat* "setup" "dbdir-space-required") "1000000"))) | > | | > | > | 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 | (get-df dirpath) 0))) (list (> dbspace required) dbspace required dirpath))) ;;====================================================================== ;; check space in dbdir and in megatest dir ;; returns: ok/not dbspace required-space ;; (define (common:check-db-dir-space) (let* ((required (string->number ;; default is 1GB (or actually a billion bytes) This is the number of 1 kB blocks. (or (configf:lookup *configdat* "setup" "dbdir-space-required") "1000000"))) (dbdir (common:make-tmpdir-name *toppath* "")) ;; (db:get-dbdir)) (tdbspace (common:check-space-in-dir dbdir required)) (mdbspace (common:check-space-in-dir *toppath* required))) (sort (list tdbspace mdbspace) (lambda (a b) (< (cadr a)(cadr b)))))) ;;====================================================================== ;; check available space in dbdir, exit if insufficient ;; (define (common:check-db-dir-and-exit-if-insufficient) (let* ((spacedat (car (common:check-db-dir-space))) ;; look only at worst for now (is-ok (car spacedat)) (dbspace (cadr spacedat)) (required (caddr spacedat)) (dbdir (cadddr spacedat))) (if (not is-ok) (begin (debug:print-error 0 *default-log-port* "Insufficient space in " dbdir ", require " required ", have " dbspace ", exiting now.") (exit 1))))) ;;====================================================================== ;; paths is list of lists ((name path) ... ) ;; (define (common:get-disk-with-most-free-space disks minsize) (let* ((best #f) (bestsize 0) (default-min-inodes-string "1000000") (default-min-inodes (string->number default-min-inodes-string)) |
︙ | ︙ | |||
2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 | ;;(print "Processing: " disk-num " bestsize: " bestsize " best: " best " freespc: " freespc " min-inodes: " min-inodes " free-inodes: " free-inodes) )) (map car disks)) (if (and best (> bestsize minsize)) best #f))) ;; #f means no disk candidate found ;; convert a spec string to a list of vectors #( rx action rx-string ) (define (common:spec-string->list-of-specs spec-string actions) (let ((spec-strings (string-split-fields "\\s*;\\s*" spec-string #:infix)) (actions-regex (regexp (conc "^(.*)\\s+(" (string-intersperse (map conc actions) "|") ")")))) (filter (lambda (x) x) (map (lambda (s) (let ((m (string-match actions-regex s))) (if m (vector (regexp (cadr m))(string->symbol (caddr m))(cadr m)) (begin (debug:print 0 *default-log-port* "WARNING: Unrecognised rule \"" s "\" in clean-up specification.") #f)))) spec-strings)))) ;; given a list of specs rx . rule and a file return the first matching rule ;; (define (common:file-find-rule fname rules) ;; rule is vector #( rx action rx-string) (let loop ((rule (car rules)) (tail (cdr rules))) (let ((rx (vector-ref rule 0)) (rn (vector-ref rule 1))) ;; rule name (if (string-match rx fname) rule ;; return the whole rule so regex can be printed etc. (if (null? tail) #f (loop (car tail)(cdr tail))))))) ;; given a spec apply some rules to a directory ;; ;; WARNING: This function will REMOVE files - be sure your spec and path is correct! ;; ;; spec format: ;; file-regex1 action; file-regex2 action; ... ;; e.g. | > > > | 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 | ;;(print "Processing: " disk-num " bestsize: " bestsize " best: " best " freespc: " freespc " min-inodes: " min-inodes " free-inodes: " free-inodes) )) (map car disks)) (if (and best (> bestsize minsize)) best #f))) ;; #f means no disk candidate found ;;====================================================================== ;; convert a spec string to a list of vectors #( rx action rx-string ) (define (common:spec-string->list-of-specs spec-string actions) (let ((spec-strings (string-split-fields "\\s*;\\s*" spec-string #:infix)) (actions-regex (regexp (conc "^(.*)\\s+(" (string-intersperse (map conc actions) "|") ")")))) (filter (lambda (x) x) (map (lambda (s) (let ((m (string-match actions-regex s))) (if m (vector (regexp (cadr m))(string->symbol (caddr m))(cadr m)) (begin (debug:print 0 *default-log-port* "WARNING: Unrecognised rule \"" s "\" in clean-up specification.") #f)))) spec-strings)))) ;;====================================================================== ;; given a list of specs rx . rule and a file return the first matching rule ;; (define (common:file-find-rule fname rules) ;; rule is vector #( rx action rx-string) (let loop ((rule (car rules)) (tail (cdr rules))) (let ((rx (vector-ref rule 0)) (rn (vector-ref rule 1))) ;; rule name (if (string-match rx fname) rule ;; return the whole rule so regex can be printed etc. (if (null? tail) #f (loop (car tail)(cdr tail))))))) ;;====================================================================== ;; given a spec apply some rules to a directory ;; ;; WARNING: This function will REMOVE files - be sure your spec and path is correct! ;; ;; spec format: ;; file-regex1 action; file-regex2 action; ... ;; e.g. |
︙ | ︙ | |||
2560 2561 2562 2563 2564 2565 2566 | (let ((rule (common:file-find-rule p specs))) (cond ((directory? p)(hash-table-set! directories p #t)) (else (case (vector-ref rule 1) ((keep)(hash-table-set! keepers p rule)) ((remove) | | | | | < < < < < < < | | > > > | > > < < < > | | 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 | (let ((rule (common:file-find-rule p specs))) (cond ((directory? p)(hash-table-set! directories p #t)) (else (case (vector-ref rule 1) ((keep)(hash-table-set! keepers p rule)) ((remove) (debug:print 0 *default-log-port* "Removing file " p) (delete-file p)) ((compress) (debug:print 0 *default-log-port* "Compressing file " p) (system (conc compress " " p))) (else (debug:print 0 *default-log-port* "No match for file " p)))))))) (if remove-empty (for-each (lambda (d) (if (null? (glob (conc d "/.*")(conc d "/*"))) (begin (debug:print 0 *default-log-port* "Removing empty directory " d) (delete-directory d)))) (sort (hash-table-keys directories) (lambda (a b)(> (string-length a)(string-length b)))))) )) ;;====================================================================== ;; E N V I R O N M E N T V A R S ;;====================================================================== (define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF" "MAKEOVERRIDES" "HOSTNAME" "PROMPT_COMMAND"))) ;;(bb-check-path msg: "save-environment-as-files entry") (let ((envvars (get-environment-variables)) (whitesp (regexp "[^a-zA-Z0-9_\\-:,\\.\\/%$]")) (mungeval (lambda (val) (cond ((eq? val #t) "") ;; convert #t to empty string ((eq? val #f) #f) ;; convert #f to itself (still thinking about this one (else val))))) (with-output-to-file (conc fname ".csh") (lambda () (for-each (lambda (keyval) (let* ((key (car keyval)) (val (cdr keyval)) (delim (if (and (string-search whitesp val) (not (string-search "^\".*\"$" val)) (not (string-search "^'.*'$" val))) "\"" ""))) (print (if (or (member key ignorevars) (string-search whitesp key)) "# setenv " "setenv ") key " " delim (mungeval val) delim))) envvars))) (with-output-to-file (conc fname ".sh") (lambda () (for-each (lambda (keyval) (let* ((key (car keyval)) (val (cdr keyval)) (delim (if (and (string-search whitesp val) (not (string-search "^\".*\"$" val)) (not (string-search "^'.*'$" val))) "\"" ""))) (print (if (or (member key ignorevars) (string-search whitesp key) (string-search ":" key)) ;; internal only values to be skipped. "# export " "export ") key "=" delim (mungeval val) delim))) envvars))))) (define (common:get-param-mapping #!key (flavor #f)) "returns alist mapping string keys in testconfig/subrun to megatest command line switches; if flavor is switch-symbol, maps tcmt symbolic switches to megatest switches" (let ((default '(("tag-expr" . "-tagexpr") ("mode-patt" . "-modepatt") ("run-name" . "-runname") ("contour" . "-contour") ("target" . "-target") ("test-patt" . "-testpatt") ("msg" . "-m") ("log" . "-log") ("start-dir" . "-start-dir") ("new" . "-set-state-status")))) (if (eq? flavor 'switch-symbol) (map (lambda (x) (cons (string->symbol (conc "-" (car x))) (cdr x))) default) default))) ;;====================================================================== ;; set some env vars from an alist, return an alist with original values ;; (("VAR" "value") ...) ;; a value of #f means "unset this var" ;; (define (alist->env-vars lst) (if (list? lst) (let ((res '())) (for-each (lambda (p) (let* ((var (car p)) (val (cadr p)) (prv (get-environment-variable var))) (set! res (cons (list var prv) res)) (if val (safe-setenv var (->string val)) (unsetenv var)))) lst) res) '())) ;;====================================================================== ;; clear vars matching pattern, run proc, set vars back ;; if proc is a string run that string as a command with ;; system. ;; (define *common:orig-env* (let ((envvars (get-environment-variables))) (if (get-environment-variable "MT_ORIG_ENV") |
︙ | ︙ | |||
2716 2717 2718 2719 2720 2721 2722 | ((string? proc)(system proc)) (proc (proc))) (hash-table-for-each vars (lambda (var val) (setenv var val))) vars)) | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > | 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 | ((string? proc)(system proc)) (proc (proc))) (hash-table-for-each vars (lambda (var val) (setenv var val))) vars)) (define (common:run-a-command cmd #!key (with-vars #f) (with-orig-env #f)) (let* ((pre-cmd (dtests:get-pre-command)) (post-cmd (dtests:get-post-command)) (fullcmd (if (or pre-cmd post-cmd) (conc pre-cmd cmd post-cmd) (conc "viewscreen " cmd)))) (debug:print-info 02 *default-log-port* "Running command: " fullcmd) (cond (with-vars (common:without-vars fullcmd)) (with-orig-env (common:with-orig-env fullcmd)) (else (common:without-vars fullcmd "MT_.*"))))) ;;====================================================================== ;; C O L O R S ;;====================================================================== (define (common:name->iup-color name) (case (string->symbol (string-downcase name)) ((red) "223 33 49") ((grey) "192 192 192") ((orange) "255 172 13") ((purple) "This is unfinished ..."))) ;;====================================================================== ;; (define (common:get-color-for-state-status state status) ;; (case (string->symbol state) ;; ((COMPLETED) ;; (case (string->symbol status) ;; ((PASS) "70 249 73") ;; ((WARN WAIVED) "255 172 13") ;; ((SKIP) "230 230 0") |
︙ | ︙ | |||
3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 | (string-split instr))) "/")) ;;====================================================================== ;; L O C K I N G M E C H A N I S M S ;;====================================================================== ;; faux-lock is deprecated. Please use simple-lock below ;; (define (common:faux-lock keyname #!key (wait-time 8)(allow-lock-steal #t)) (if (rmt:no-sync-get/default keyname #f) ;; do not be tempted to compare to pid. locking is a one-shot action, if already locked for this pid it doesn't actually count (if (> wait-time 0) (begin (thread-sleep! 1) | > | 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 | (string-split instr))) "/")) ;;====================================================================== ;; L O C K I N G M E C H A N I S M S ;;====================================================================== ;;====================================================================== ;; faux-lock is deprecated. Please use simple-lock below ;; (define (common:faux-lock keyname #!key (wait-time 8)(allow-lock-steal #t)) (if (rmt:no-sync-get/default keyname #f) ;; do not be tempted to compare to pid. locking is a one-shot action, if already locked for this pid it doesn't actually count (if (> wait-time 0) (begin (thread-sleep! 1) |
︙ | ︙ | |||
3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 | (define (common:faux-unlock keyname #!key (force #f)) (if (or force (equal? (conc (current-process-id)) (conc (rmt:no-sync-get/default keyname #f)))) (begin (if (rmt:no-sync-get/default keyname #f) (rmt:no-sync-del! keyname)) #t) #f)) ;; simple lock. improve and converge on this one. ;; (define (common:simple-lock keyname) (rmt:no-sync-get-lock keyname)) (define (common:simple-unlock keyname #!key (force #f)) (rmt:no-sync-del! keyname)) | > < | | | | 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 | (define (common:faux-unlock keyname #!key (force #f)) (if (or force (equal? (conc (current-process-id)) (conc (rmt:no-sync-get/default keyname #f)))) (begin (if (rmt:no-sync-get/default keyname #f) (rmt:no-sync-del! keyname)) #t) #f)) ;;====================================================================== ;; simple lock. improve and converge on this one. ;; (define (common:simple-lock keyname) (rmt:no-sync-get-lock keyname)) (define (common:simple-unlock keyname #!key (force #f)) (rmt:no-sync-del! keyname)) ;;====================================================================== ;; ;;====================================================================== (define (common:in-running-test?) (and (args:get-arg "-execute") (get-environment-variable "MT_CMDINFO"))) (define (common:get-color-from-status status) (cond ((equal? status "PASS") "green") ((equal? status "FAIL") "red") ((equal? status "WARN") "orange") ((equal? status "KILLED") "orange") ((equal? status "KILLREQ") "purple") ((equal? status "RUNNING") "blue") ((equal? status "ABORT") "brown") (else "black"))) ;;====================================================================== ;; N A N O M S G C L I E N T ;;====================================================================== ;; ;; ;; ;; (define (common:send-dboard-main-changed) ;; (let* ((dashboard-ips (mddb:get-dashboards))) ;; (for-each ;; (lambda (ipadr) |
︙ | ︙ | |||
3284 3285 3286 3287 3288 3289 3290 3291 | (loop (car tal)(cdr tal))))))) ;; no match, try again (if (null? tal) fallback-launcher (loop (car tal)(cdr tal)))))))) fallback-launcher))) ;;====================================================================== | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | > > > | > | 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 | (loop (car tal)(cdr tal))))))) ;; no match, try again (if (null? tal) fallback-launcher (loop (car tal)(cdr tal)))))))) fallback-launcher))) ;;====================================================================== ;; D A S H B O A R D U S E R V I E W S ;;====================================================================== ;;====================================================================== ;; first read ~/views.config if it exists, then read $MTRAH/views.config if it exists ;; (define (common:load-views-config) (let* ((view-cfgdat (make-hash-table)) (home-cfgfile (conc (get-environment-variable "HOME") "/.mtviews.config")) (mthome-cfgfile (conc *toppath* "/.mtviews.config"))) (if (common:file-exists? mthome-cfgfile) (read-config mthome-cfgfile view-cfgdat #t)) ;; we load the home dir file AFTER the MTRAH file so the user can clobber settings when running the dashboard in read-only areas (if (common:file-exists? home-cfgfile) (read-config home-cfgfile view-cfgdat #t)) view-cfgdat)) ;;====================================================================== ;; H I E R A R C H I C A L H A S H T A B L E S ;;====================================================================== ;; ;; Every element including top element is a vector: ;; <vector subhash value> (define (hh:make-hh #!key (ht #f)(value #f)) (vector (or ht (make-hash-table)) value)) ;;====================================================================== ;; used internally (define-inline (hh:set-ht! hh ht) (vector-set! hh 0 ht)) (define-inline (hh:get-ht hh) (vector-ref hh 0)) (define-inline (hh:set-value! hh value) (vector-set! hh 1 value)) (define-inline (hh:get-value hh value) (vector-ref hh 1)) ;;====================================================================== ;; given a hierarchial hash and some keys look up the value ... ;; (define (hh:get hh . keys) (if (null? keys) (vector-ref hh 1) ;; we have reached the end of the line, return the value sought (let ((sub-ht (hh:get-ht hh))) (if sub-ht ;; yes, there is more hierarchy (let ((sub-hh (hash-table-ref/default sub-ht (car keys) #f))) (if sub-hh (apply hh:get sub-hh (cdr keys)) #f)) #f)))) ;;====================================================================== ;; given a hierarchial hash, a value and some keys, add needed hierarcy and insert the value ;; (define (hh:set! hh value . keys) (if (null? keys) (hh:set-value! hh value) ;; we have reached the end of the line, store the value (let ((sub-ht (hh:get-ht hh))) (if sub-ht ;; yes, there is more hierarchy (let ((sub-hh (hash-table-ref/default sub-ht (car keys) #f))) (if (not sub-hh) ;; we'll need to add the next level of hierarchy (let ((new-sub-hh (hh:make-hh))) (hash-table-set! sub-ht (car keys) new-sub-hh) (apply hh:set! new-sub-hh value (cdr keys))) (apply hh:set! sub-hh value (cdr keys)))) ;; call the sub-hierhash with remaining keys (begin (hh:set-ht! hh (make-hash-table)) (apply hh:set! hh value keys)))))) ;;====================================================================== ;; Manage pkts, used in servers, tests and likely other contexts so put ;; in common ;;====================================================================== (define common:pkts-spec '((default . ((parent . P) (action . a) |
︙ | ︙ | |||
3422 3423 3424 3425 3426 3427 3428 3429 3430 | (current-directory)) "/lt/.pkts")))) (pktsdirs (if pktsdirs-str (string-split pktsdirs-str " ") #f))) pktsdirs)) ;; use-lt is use linktree "lt" link to find pkts dir (define (common:save-pkt pktalist-in mtconf use-lt #!key (add-only #f)) ;; add-only saves the pkt only if there is a parent already | > | > | 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 | (current-directory)) "/lt/.pkts")))) (pktsdirs (if pktsdirs-str (string-split pktsdirs-str " ") #f))) pktsdirs)) ;;====================================================================== ;; use-lt is use linktree "lt" link to find pkts dir (define (common:save-pkt pktalist-in mtconf use-lt #!key (add-only #f)) ;; add-only saves the pkt only if there is a parent already (if (or (not add-only) (hash-table-exists? *pkts-info* 'last-parent)) (let* ((parent (hash-table-ref/default *pkts-info* 'last-parent #f)) (pktalist (if parent (cons `(parent . ,parent) pktalist-in) pktalist-in))) (let-values (((uuid pkt) (alist->pkt pktalist common:pkts-spec))) (hash-table-set! *pkts-info* 'last-parent uuid) (let ((pktsdir (or (hash-table-ref/default *pkts-info* 'pkts-dir #f) (let* ((pktsdirs (common:get-pkts-dirs mtconf use-lt)) (pktsdir (car pktsdirs))) ;; assume it is there (hash-table-set! *pkts-info* 'pkts-dir pktsdir) pktsdir)))) (debug:print 0 *default-log-port* "pktsdir: "pktsdir) (handle-exceptions exn (debug:print-info 0 "failed to write out packet to " pktsdir ", exn=" exn) ;; don't care if this failed for now but MUST FIX - BUG!! (if (not (file-exists? pktsdir)) (create-directory pktsdir #t)) (with-output-to-file (conc pktsdir "/" uuid ".pkt") |
︙ | ︙ | |||
3484 3485 3486 3487 3488 3489 3490 | (debug:print 0 *default-log-port* "ERROR: packets directory " pktsdir " does not exist.")) ((not (directory? pktsdir)) (debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not a directory.")) ((not (file-read-access? pktsdir)) (debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not readable.")) (else (debug:print-info 0 *default-log-port* "Loading packets found in " pktsdir) | | > > > > > > | > | < | 2998 2999 3000 3001 3002 3003 3004 3005 3006 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 | (debug:print 0 *default-log-port* "ERROR: packets directory " pktsdir " does not exist.")) ((not (directory? pktsdir)) (debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not a directory.")) ((not (file-read-access? pktsdir)) (debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not readable.")) (else (debug:print-info 0 *default-log-port* "Loading packets found in " pktsdir) (let ((pkts (glob (conc pktsdir "/*.pkt"))) (sqdb (dbi:db-conn pdb)) ) ;; Put this in a transaction to avoid issues overloading the db (sqlite3:with-transaction sqdb (lambda () (for-each (lambda (pkt) (let* ((uuid (cadr (string-match ".*/([0-9a-f]+).pkt" pkt))) (exists (lookup-by-uuid pdb uuid #f))) (if (not exists) (let* ((pktdat (string-intersperse (with-input-from-file pkt read-lines) "\n")) (apkt (pkt->alist pktdat)) (ptype (alist-ref 'T apkt))) (add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0) (debug:print 4 *default-log-port* "Added " uuid " of type " ptype " to queue")) (debug:print 4 *default-log-port* "pkt: " uuid " exists, skipping...") ))) pkts))))))) pktsdirs)) use-lt: use-lt)) (define (common:get-pkt-alists pkts) (map (lambda (x) (alist-ref 'apkt x)) ;; 'pkta pulls out the alist from the read pkt pkts)) ;;====================================================================== ;; given list of pkts (alist mode) return list of D cards as Unix epoch, sorted descending ;; also delete duplicates by target i.e. (car pkt) ;; (define (common:get-pkt-times pkts) (delete-duplicates (sort (map (lambda (x) `(,(alist-ref 't x) . ,(string->number (alist-ref 'D x)))) pkts) (lambda (a b)(> (cdr a)(cdr b)))) ;; sort descending (lambda (a b)(equal? (car a)(car b))))) ;; remove duplicates by target ;;====================================================================== ;; accept an alist or hash table containing envvar/env value pairs (value of #f causes unset) ;; execute thunk in context of environment modified as per this list ;; restore env to prior state then return value of eval'd thunk. ;; ** this is not thread safe ** (define (common:with-env-vars delta-env-alist-or-hash-table thunk) (let* ((delta-env-alist (if (hash-table? delta-env-alist-or-hash-table) (hash-table->alist delta-env-alist-or-hash-table) |
︙ | ︙ | |||
3565 3566 3567 3568 3569 3570 3571 | (let ((rv (thunk))) (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state rv))) (define *common:thread-punchlist* (make-hash-table)) (define (common:send-thunk-to-background-thread thunk #!key (name #f)) ;;(BB> "launched thread " name) | < | 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 | (let ((rv (thunk))) (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state rv))) (define *common:thread-punchlist* (make-hash-table)) (define (common:send-thunk-to-background-thread thunk #!key (name #f)) ;;(BB> "launched thread " name) ;; we need a unique name for the thread. (let* ((realname (if name (if (not (hash-table-ref/default *common:thread-punchlist* name #f)) name (conc name"-" (symbol->string (gensym)))) (conc "anonymous-"(symbol->string (gensym))))) (realthunk (lambda () |
︙ | ︙ | |||
3596 3597 3598 3599 3600 3601 3602 | (begin (debug:print 0 *default-log-port* "joining threads failed. exn=" exn) #t) ;; just ignore it, it might have died in the meantime so joining it will throw an exception (thread-join! thread)) ))) (hash-table-keys *common:thread-punchlist*))) | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < > | | | | | | | | | | | | | | | | | | | | < > | | | | | 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 | (begin (debug:print 0 *default-log-port* "joining threads failed. exn=" exn) #t) ;; just ignore it, it might have died in the meantime so joining it will throw an exception (thread-join! thread)) ))) (hash-table-keys *common:thread-punchlist*))) ;;====================================================================== ;; (define *common:telemetry-log-state* 'startup) ;; (define *common:telemetry-log-socket* #f) ;; ;; (define (common:telemetry-log-open) ;; (if (eq? *common:telemetry-log-state* 'startup) ;; (let* ((serverhost (configf:lookup *configdat* "telemetry" "host")) ;; (serverport (configf:lookup-number *configdat* "telemetry" "port")) ;; (user (or (get-environment-variable "USER") "unknown")) ;; (host (or (get-environment-variable "HOST") "unknown"))) ;; (set! *common:telemetry-log-state* ;; (handle-exceptions ;; exn ;; (begin ;; (debug:print-info 0 *default-log-port* "common-telemetry-log open udp port failure") ;; 'broken) ;; (if (and serverhost serverport user host) ;; (let* ((s (udp-open-socket))) ;; ;;(udp-bind! s #f 0) ;; (udp-connect! s serverhost serverport) ;; (set! *common:telemetry-log-socket* s) ;; 'open) ;; 'not-needed)))))) ;; ;; (define (common:telemetry-log event #!key (payload '())) ;; (if (eq? *common:telemetry-log-state* 'startup) ;; (common:telemetry-log-open)) ;; ;; (if (eq? 'open *common:telemetry-log-state*) ;; (handle-exceptions ;; exn ;; (begin ;; (debug:print-info 0 *default-log-port* "common-telemetry-log comms failure ; disabled (no server?)") ;; ;;(define *common:telemetry-log-state* 'broken-or-no-server-preclose) ;; ;;(common:telemetry-log-close) ;; (define *common:telemetry-log-state* 'broken-or-no-server) ;; (set! *common:telemetry-log-socket* #f) ;; ) ;; (if (and *common:telemetry-log-socket* event) ;; TODO - filter on event against telemetry.want-events ;; (let* ((user (or (get-environment-variable "USER") "unknown")) ;; (host (or (get-environment-variable "HOST") "unknown")) ;; (start (conc "[megatest "event"]")) ;; (toppath (or *toppath* "/dev/null")) ;; (payload-serialized ;; (base64:base64-encode ;; (z3:encode-buffer ;; (with-output-to-string (lambda () (pp payload)))))) ;; (msg (conc user":"host":"start":"(current-process-id)":"(car (argv))":" ;; toppath":"payload-serialized))) ;; (udp-send *common:telemetry-log-socket* msg)))))) ;; ;; (define (common:telemetry-log-close) ;; (when (or (member *common:telemetry-log-state* '(broken-or-no-server-preclose open)) *common:telemetry-log-socket*) ;; (handle-exceptions ;; exn ;; (begin ;; (define *common:telemetry-log-state* 'closed-fail) ;; (debug:print-info 0 *default-log-port* "common-telemetry-log closure failure") ;; ) ;; (begin ;; (define *common:telemetry-log-state* 'closed) ;; (udp-close-socket *common:telemetry-log-socket*) ;; (set! *common:telemetry-log-socket* #f))))) |
Modified common_records.scm from [80f9e14f2d] to [0bd4438bf6].
︙ | ︙ | |||
79 80 81 82 83 84 85 | (mutex-unlock! mtx) res)) ;; this was cached based on results from profiling but it turned out the profiling ;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching ;; in for now but can probably take it out later. ;; | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | (mutex-unlock! mtx) res)) ;; this was cached based on results from profiling but it turned out the profiling ;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching ;; in for now but can probably take it out later. ;; ;; (define (debug:calc-verbosity vstr) ;; (or (hash-table-ref/default *verbosity-cache* vstr #f) ;; (let ((res (cond ;; ((number? vstr) vstr) ;; ((not (string? vstr)) 1) ;; ;; ((string-match "^\\s*$" vstr) 1) ;; (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ","))))) ;; (cond ;; ((> (length debugvals) 1) debugvals) ;; ((> (length debugvals) 0)(car debugvals)) ;; (else 1)))) ;; ((args:get-arg "-v") 2) ;; ((args:get-arg "-q") 0) ;; (else 1)))) ;; (hash-table-set! *verbosity-cache* vstr res) ;; res))) ;; ;; check verbosity, #t is ok ;; (define (debug:check-verbosity verbosity vstr) ;; (if (not (or (number? verbosity) ;; (list? verbosity))) ;; (begin ;; (print "ERROR: Invalid debug value \"" vstr "\"") ;; #f) ;; #t)) ;; ;; (define (debug:debug-mode n) ;; (cond ;; ((and (number? *verbosity*) ;; number number ;; (number? n)) ;; (<= n *verbosity*)) ;; ((and (list? *verbosity*) ;; list number ;; (number? n)) ;; (member n *verbosity*)) ;; ((and (list? *verbosity*) ;; list list ;; (list? n)) ;; (not (null? (lset-intersection! eq? *verbosity* n)))) ;; ((and (number? *verbosity*) ;; (list? n)) ;; (member *verbosity* n)))) ;; ;; (define (debug:setup) ;; (let ((debugstr (or (args:get-arg "-debug") ;; (args:get-arg "-debug-noprop") ;; (getenv "MT_DEBUG_MODE")))) ;; (set! *verbosity* (debug:calc-verbosity debugstr)) ;; (debug:check-verbosity *verbosity* debugstr) ;; ;; if we were handed a bad verbosity rule then we will override it with 1 and continue ;; (if (not *verbosity*)(set! *verbosity* 1)) ;; (if (and (not (args:get-arg "-debug-noprop")) ;; (or (args:get-arg "-debug") ;; (not (getenv "MT_DEBUG_MODE")))) ;; (setenv "MT_DEBUG_MODE" (if (list? *verbosity*) ;; (string-intersperse (map conc *verbosity*) ",") ;; (conc *verbosity*)))))) ;; ;; (define (debug:print n e . params) ;; (if (debug:debug-mode n) ;; (with-output-to-port (or e (current-error-port)) ;; (lambda () ;; (if *logging* ;; (db:log-event (apply conc params)) ;; (apply print params) ;; ))))) ;; Brandon's debug printer shortcut (indulge me :) ;; (define *BB-process-starttime* (current-milliseconds)) ;; (define (BB> . in-args) ;; (let* ((stack (get-call-chain)) ;; (location "??")) ;; (for-each ;; (lambda (frame) ;; (let* ((this-loc (vector-ref frame 0)) ;; (temp (string-split (->string this-loc) " ")) ;; (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???"))) ;; (if (equal? this-func "BB>") ;; (set! location this-loc)))) ;; stack) ;; (let* ((color-on "\x1b[1m") ;; (color-off "\x1b[0m") ;; (dp-args ;; (append ;; (list 0 *default-log-port* ;; (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off " ") ) ;; in-args))) ;; (apply debug:print dp-args)))) ;; ;; (define *BBpp_custom_expanders_list* (make-hash-table)) ;; ;; ;; ;; ;; register hash tables with BBpp. ;; (hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE: ;; (cons hash-table? hash-table->alist)) ;; ;; ;; test name converter ;; (define (BBpp_custom_converter arg) ;; (let ((res #f)) ;; (for-each ;; (lambda (custom-type-name) ;; (let* ((custom-type-info (hash-table-ref *BBpp_custom_expanders_list* custom-type-name)) ;; (custom-type-test (car custom-type-info)) ;; (custom-type-converter (cdr custom-type-info))) ;; (when (and (not res) (custom-type-test arg)) ;; (set! res (custom-type-converter arg))))) ;; (hash-table-keys *BBpp_custom_expanders_list*)) ;; (if res (BBpp_ res) arg))) ;; ;; (define (BBpp_ arg) ;; (cond ;; ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg))) ;; ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg))) ;; ((hash-table? arg) ;; (let ((al (hash-table->alist arg))) ;; (BBpp_ (cons HASH_TABLE: al)))) ;; ((null? arg) '()) ;; ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg)))) ;; ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg)))) ;; (else (BBpp_custom_converter arg)))) ;; ;; ;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp ;; (define (BBpp arg) ;; (pp (BBpp_ arg))) ;(use define-macro) (define-syntax inspect (syntax-rules () [(_ x) ;; (with-output-to-port (current-error-port) (printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x)))) ;; ) ] [(_ x y ...) (begin (inspect x) (inspect y ...))])) ;; (define (debug:print-error n e . params) ;; ;; normal print ;; (if (debug:debug-mode n) ;; (with-output-to-port (if (port? e) e (current-error-port)) ;; (lambda () ;; (if *logging* ;; (db:log-event (apply conc params)) ;; ;; (apply print "pid:" (current-process-id) " " params) ;; (apply print "ERROR: " params) ;; )))) ;; ;; pass important messages to stderr ;; (if (and (eq? n 0)(not (eq? e (current-error-port)))) ;; (with-output-to-port (current-error-port) ;; (lambda () ;; (apply print "ERROR: " params) ;; )))) ;; ;; (define (debug:print-info n e . params) ;; (if (debug:debug-mode n) ;; (with-output-to-port (if (port? e) e (current-error-port)) ;; (lambda () ;; (if *logging* ;; (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params)))) ;; (db:log-event res)) ;; ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res) ;; (apply print "INFO: (" n ") " params) ;; res) ;; ))))) ;; ;; if a value is printable (i.e. string or number) return the value ;; else return an empty string (define-inline (printable val) (if (or (number? val)(string? val)) val "")) |
Modified commonmod.scm from [9423abd515] to [faac2f70ad].
︙ | ︙ | |||
15 16 17 18 19 20 21 22 23 24 | ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit commonmod)) (module commonmod * | > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > | > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;; ;; 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 commonmod)) (declare (uses debugprint)) (use srfi-69) (module commonmod * (import scheme) (cond-expand (chicken-4 (import chicken ports (prefix sqlite3 sqlite3:) data-structures extras files matchable md5 message-digest pathname-expand posix posix-extras regex regex-case srfi-1 srfi-18 srfi-69 typed-records debugprint ) (use srfi-69)) (chicken-5 (import (prefix sqlite3 sqlite3:) ;; data-structures ;; extras ;; files ;; posix ;; posix-extras chicken.base chicken.condition chicken.file chicken.file.posix chicken.io chicken.pathname chicken.port chicken.process chicken.process-context chicken.process-context.posix chicken.sort chicken.string chicken.time chicken.time.posix matchable md5 message-digest pathname-expand regex regex-case srfi-1 srfi-18 srfi-69 typed-records system-information debugprint ))) ;;====================================================================== ;; CONTENTS ;; ;; config file utils ;; misc conversion, data manipulation functions ;; testsuite and area utilites ;; ;;====================================================================== (include "megatest-version.scm") (include "megatest-fossil-hash.scm") ;; http - use the old http + in /tmp db ;; tcp - use tcp transport with cachedb db ;; nfs - use direct to disk access (read-only) ;; (define rmt:transport-mode (make-parameter 'tcp)) (define (get-full-version) (conc megatest-version "-" megatest-fossil-hash)) (define (version-signature) (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) (define *common:denoise* (make-hash-table)) ;; for low noise printing (define (common:low-noise-print waitval . keys) (let* ((key (string-intersperse (map conc keys) "-" )) (lasttime (hash-table-ref/default *common:denoise* key 0)) (currtime (current-seconds))) (if (> (- currtime lasttime) waitval) (begin (hash-table-set! *common:denoise* key currtime) #t) #f))) ;; KEEP THIS ONE ;; ;; client:get-signature (define *my-client-signature* #f) (define (client:get-signature) (if *my-client-signature* *my-client-signature* (let ((sig (conc (get-host-name) " " (current-process-id)))) (set! *my-client-signature* sig) *my-client-signature*))) ;;====================================================================== ;; config file utils ;;====================================================================== (define (lookup cfgdat section var) (if (hash-table? cfgdat) |
︙ | ︙ | |||
70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 | (if valstr (val->alist valstr) '()))) ;; should it return empty list or #f to indicate not set? (define (get-section cfgdat section) (hash-table-ref/default cfgdat section '())) ;;====================================================================== ;; misc conversion, data manipulation functions ;;====================================================================== ;; if it looks like a number -> convert it to a number, else return it ;; (define (lazy-convert inval) (let* ((as-num (if (string? inval)(string->number inval) #f))) (or as-num inval))) ;; to '((a . 1)(b . 2)(c . "a silly thing")(d . "")) | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (if valstr (val->alist valstr) '()))) ;; should it return empty list or #f to indicate not set? (define (get-section cfgdat section) (hash-table-ref/default cfgdat section '())) (define (common:make-tmpdir-name areapath tmpadj) (let* ((area (pathname-file areapath)) (dname (conc "/tmp/"(current-user-name)"/megatest_localdb/" area "/" (string-translate areapath "/" ".") tmpadj "/.mtdb"))) (unless (directory-exists? dname) (create-directory dname #t)) dname)) ;; dot-locking egg seems not to work, using this for now ;; if lock is older than expire-time then remove it and try again ;; to get the lock ;; (define (common:simple-file-lock fname #!key (expire-time 300)) (let* ((lock-exists (file-exists? fname)) (fmod-time (if lock-exists (current-seconds) (handle-exceptions ext (current-seconds) (file-modification-time fname))))) (if lock-exists (if (> (- (current-seconds) fmod-time) expire-time) (begin (debug:print-info 1 *default-log-port* "Removing stale lock "fname) (handle-exceptions exn #f (delete-file* fname)) (common:simple-file-lock fname expire-time: expire-time)) #f) (let ((key-string (conc (get-host-name) "-" (current-process-id)))) (with-output-to-file fname (lambda () (print key-string))) (thread-sleep! 0.25) (if (file-exists? fname) ;; (common:file-exists? fname) (handle-exceptions exn #f (with-input-from-file fname (lambda () (equal? key-string (read-line))))) #f))))) (define (common:simple-file-lock-and-wait fname #!key (expire-time 300)) (let ((end-time (+ expire-time (current-seconds)))) (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time))) (if got-lock #t (if (> end-time (current-seconds)) (begin (thread-sleep! 3) (loop (common:simple-file-lock fname expire-time: expire-time))) #f))))) (define (common:simple-file-release-lock fname) (handle-exceptions exn #f ;; I don't really care why this failed (at least for now) (delete-file* fname))) ;;====================================================================== ;; misc conversion, data manipulation functions ;;====================================================================== ;;====================================================================== ;; return first command that exists, else #f ;; (define (common:which cmds) (if (null? cmds) #f (let loop ((hed (car cmds)) (tal (cdr cmds))) (let ((res (with-input-from-pipe (conc "which " hed) read-line))) (if (and (string? res) (file-exists? res)) res (if (null? tal) #f (loop (car tal)(cdr tal)))))))) (define (common:get-megatest-exe) (let* ((mtexe (or (get-environment-variable "MT_MEGATEST") (common:which '("megatest")) "megatest"))) (if (file-exists? mtexe) (realpath mtexe) mtexe))) (define (common:get-megatest-exe-dir) (let* ((mtexe (common:get-megatest-exe))) (pathname-directory mtexe))) ;; more generic and comprehensive version of get-megatest-exe ;; (define (common:get-mtexe) (let* ((mtpathdir (common:get-megatest-exe-dir))) (or (common:get-megatest-exe) (if mtpathdir (conc mtpathdir"/megatest") #f) "megatest"))) (define (common:get-megatest-exe-path) (let* ((mtpathdir (common:get-megatest-exe-dir))) (conc mtpathdir":"(get-environment-variable "PATH") ":."))) (cond-expand (chicken-4 (define (realpath x) (resolve-pathname (pathname-expand (or x "/dev/null")) ))) (chicken-5 (define (realpath x) (normalize-pathname (pathname-expand (or x "/dev/null")))))) ;; if it looks like a number -> convert it to a number, else return it ;; (define (lazy-convert inval) (let* ((as-num (if (string? inval)(string->number inval) #f))) (or as-num inval))) ;; to '((a . 1)(b . 2)(c . "a silly thing")(d . "")) |
︙ | ︙ | |||
100 101 102 103 104 105 106 107 108 109 110 111 112 113 | (if convert (lazy-convert inval) inval)))) (else f)))) (filter (lambda (x) (not (string-match "^\\s*" x))) val-list)) '()))) ;;====================================================================== ;; testsuite and area utilites ;;====================================================================== (define (get-testsuite-name toppath configdat) (or (lookup configdat "setup" "area-name") (lookup configdat "setup" "testsuite") | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (if convert (lazy-convert inval) inval)))) (else f)))) (filter (lambda (x) (not (string-match "^\\s*" x))) val-list)) '()))) (define (commonmod:get-cpu-load) (let* ((load-info (with-input-from-file "/proc/loadavg" read-lines)) (res (map string->number (string-split (car load-info))))) (if (null? res) #f ;; something is wrong (car res)))) (define *current-host-cores* #f) (define (get-current-host-cores) (or *current-host-cores* (let ((cpu-info (with-input-from-file "/proc/cpuinfo" read-lines))) (let loop ((lines cpu-info)) (if (null? lines) 1 ;; gotta be at least one! (let* ((inl (car lines)) (tail (cdr lines)) (parts (string-split inl))) (match parts (("cpu" "cores" ":" num) (string->number num)) (else (loop tail))))))))) (define (number-of-processes-running processname) (with-input-from-pipe (conc "ps -def | egrep \""processname"\" |wc -l") (lambda () (string->number (read-line))))) ;; get the normalized (i.e. load / numcpus) for *this* host ;; (define (get-normalized-cpu-load) (/ (commonmod:get-cpu-load)(get-current-host-cores))) ;;====================================================================== ;; testsuite and area utilites ;;====================================================================== (define (get-testsuite-name toppath configdat) (or (lookup configdat "setup" "area-name") (lookup configdat "setup" "testsuite") |
︙ | ︙ | |||
147 148 149 150 151 152 153 | ;; (define (get-cfg-areas cfgdat) (let ((adat (get-section cfgdat "areas"))) (map (lambda (entry) `(,(car entry) . ,(val->alist (cadr entry)))) adat))) | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > | > > > > > > > > > > > | > > > > > > > > > | 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 | ;; (define (get-cfg-areas cfgdat) (let ((adat (get-section cfgdat "areas"))) (map (lambda (entry) `(,(car entry) . ,(val->alist (cadr entry)))) adat))) ;;====================================================================== ;; time utils ;;====================================================================== (define (common:human-time) (time->string (seconds->local-time (current-seconds)) "%Y-%m-%d %H:%M:%S")) ;;====================================================================== ;; T I M E A N D D A T E ;;====================================================================== ;;====================================================================== ;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5 (define (common:hms-string->seconds tstr) (let ((parts (string-split-fields "\\w+" tstr)) (time-secs 0) ;; s=seconds, m=minutes, h=hours, d=days, M=months, y=years, w=weeks (trx (regexp "^(\\d+)([smhdMyw])$"))) (for-each (lambda (part) (let ((match (string-match trx part))) (if match (let ((val (string->number (cadr match))) (unt (caddr match))) (if val (set! time-secs (+ time-secs (* val (case (string->symbol unt) ((s) 1) ((m) 60) ;; minutes ((h) 3600) ((d) 86400) ((w) 604800) ((M) 2628000) ;; aproximately one month ((y) 31536000) (else 0))))) (debug:print 0 *default-log-port* "ERROR: can't parse timestring "tstr", component "part", string: "(cadr match)))) (debug:print 0 *default-log-port* "ERROR: can't parse timestring "tstr", component "part)))) parts) time-secs)) (define (seconds->hr-min-sec secs) (let* ((hrs (quotient secs 3600)) (min (quotient (- secs (* hrs 3600)) 60)) (sec (- secs (* hrs 3600)(* min 60)))) (conc (if (> hrs 0)(conc hrs "hr ") "") (if (> min 0)(conc min "m ") "") sec "s"))) (define (seconds->time-string sec) (time->string (seconds->local-time sec) "%H:%M:%S")) (define (seconds->work-week/day-time sec) (time->string (seconds->local-time sec) "ww%V.%u %H:%M")) (define (seconds->work-week/day sec) (time->string (seconds->local-time sec) "ww%V.%u")) (define (seconds->year-work-week/day sec) (time->string (seconds->local-time sec) "%yww%V.%w")) (define (seconds->year-work-week/day-time sec) (time->string (seconds->local-time sec) "%Yww%V.%w %H:%M")) (define (seconds->year-week/day-time sec) (time->string (seconds->local-time sec) "%Yw%V.%w %H:%M")) (define (seconds->quarter sec) (case (string->number (time->string (seconds->local-time sec) "%m")) ((1 2 3) 1) ((4 5 6) 2) ((7 8 9) 3) ((10 11 12) 4) (else #f))) ;;====================================================================== ;; basic ISO8601 format (e.g. "2017-02-28 06:02:54") date time => Unix epoch ;; (define (common:date-time->seconds datetime) (local-time->seconds (string->time datetime "%Y-%m-%d %H:%M:%S"))) ;;====================================================================== ;; given span of seconds tstart to tend ;; find start time to mark and mark delta ;; (define (common:find-start-mark-and-mark-delta tstart tend) (let* ((deltat (- (max tend (+ tend 10)) tstart)) ;; can't handle runs of less than 4 seconds. Pad it to 10 seconds ... (result #f) (min 60) (hr (* 60 60)) (day (* 24 hr)) (yr (* 365 day)) ;; year (mo (/ yr 12)) (wk (* day 7))) (for-each (lambda (max-blks) (for-each (lambda (span) ;; 5 2 1 (if (not result) (for-each (lambda (timeunit timesym) ;; year month day hr min sec (if (not result) (let* ((time-blk (* span timeunit)) (num-blks (quotient deltat time-blk))) (if (and (> num-blks 4)(< num-blks max-blks)) (let ((first (* (quotient tstart time-blk) time-blk))) (set! result (list span timeunit time-blk first timesym)) ))))) (list yr mo wk day hr min 1) '( y mo w d h m s)))) (list 8 6 5 2 1))) '(5 10 15 20 30 40 50 500)) (if values (apply values result) (values 0 day 1 0 'd)))) ;;====================================================================== ;; given x y lim return the cron expansion ;; (define (common:expand-cron-slash x y lim) (let loop ((curr x) (res `())) (if (< curr lim) (loop (+ curr y) (cons curr res)) (reverse res)))) ;;====================================================================== ;; expand a complex cron string to a list of cron strings ;; ;; x/y => x, x+y, x+2y, x+3y while x+Ny<max_for_field ;; a,b,c => a, b ,c ;; ;; NOTE: with flatten a lot of the crud below can be factored down. ;; (define (common:cron-expand cron-str) (if (list? cron-str) (flatten (fold (lambda (x res) (if (list? x) (let ((newres (map common:cron-expand x))) (append x newres)) (cons x res))) '() cron-str)) ;; (map common:cron-expand cron-str)) (let ((cron-items (string-split cron-str)) (slash-rx (regexp "(\\d+)/(\\d+)")) (comma-rx (regexp ".*,.*")) (max-vals '((min . 60) (hour . 24) (dayofmonth . 28) ;;; BUG!!!! This will be a bug for some combinations (month . 12) (dayofweek . 7)))) (if (< (length cron-items) 5) ;; bad spec cron-str ;; `(,cron-str) ;; just return the string, something downstream will fix it (let loop ((hed (car cron-items)) (tal (cdr cron-items)) (type 'min) (type-tal '(hour dayofmonth month dayofweek)) (res '())) (regex-case hed (slash-rx ( _ base incr ) (let* ((basen (string->number base)) (incrn (string->number incr)) (expanded-vals (common:expand-cron-slash basen incrn (alist-ref type max-vals))) (new-list-crons (fold (lambda (x myres) (cons (conc (if (null? res) "" (conc (string-intersperse res " ") " ")) x " " (string-intersperse tal " ")) myres)) '() expanded-vals))) ;; (print "new-list-crons: " new-list-crons) ;; (fold (lambda (x res) ;; (if (list? x) ;; (let ((newres (map common:cron-expand x))) ;; (append x newres)) ;; (cons x res))) ;; '() (flatten (map common:cron-expand new-list-crons)))) ;; (map common:cron-expand (map common:cron-expand new-list-crons)))) (else (if (null? tal) cron-str (loop (car tal)(cdr tal)(car type-tal)(cdr type-tal)(append res (list hed))))))))))) ;;====================================================================== ;; given a cron string and the last time event was processed return #t to run or #f to not run ;; ;; min hour dayofmonth month dayofweek ;; 0-59 0-23 1-31 1-12 0-6 ### NOTE: dayofweek does not include 7 ;; ;; #t => yes, run the job ;; #f => no, do not run the job ;; (define (common:cron-event cron-str now-seconds-in last-done) ;; ref-seconds = #f is NOW. (let* ((cron-items (map string->number (string-split cron-str))) (now-seconds (or now-seconds-in (current-seconds))) (now-time (seconds->local-time now-seconds)) (last-done-time (seconds->local-time last-done)) (all-times (make-hash-table))) ;; (print "cron-items: " cron-items "(length cron-items): " (length cron-items)) (if (not (eq? (length cron-items) 5)) ;; don't even try to figure out junk strings #f (match-let ((( cmin chour cdayofmonth cmonth cdayofweek) cron-items) ;; 0 1 2 3 4 5 6 ((nsec nmin nhour ndayofmonth nmonth nyr ndayofweek n7 n8 n9) (vector->list now-time)) ((lsec lmin lhour ldayofmonth lmonth lyr ldayofweek l7 l8 l9) (vector->list last-done-time))) ;; create all possible time slots ;; remove invalid slots due to (for example) day of week ;; get the start and end entries for the ref-seconds (current) time ;; if last-done > ref-seconds => this is an ERROR! ;; does the last-done time fall in the legit region? ;; yes => #f do not run again this command ;; no => #t ok to run the command (for-each ;; month (lambda (month) (for-each ;; dayofmonth (lambda (dom) (for-each (lambda (hr) ;; hour (for-each (lambda (minute) ;; minute (let ((copy-now (apply vector (vector->list now-time)))) (vector-set! copy-now 0 0) ;; force seconds to zero (vector-set! copy-now 1 minute) (vector-set! copy-now 2 hr) (vector-set! copy-now 3 dom) ;; dom is already corrected for zero referenced (vector-set! copy-now 4 month) (let* ((copy-now-secs (local-time->seconds copy-now)) (new-copy (seconds->local-time copy-now-secs))) ;; remake the time vector (if (or (not cdayofweek) (equal? (vector-ref new-copy 6) cdayofweek)) ;; if the day is specified and a match OR if the day is NOT specified (if (or (not cdayofmonth) (equal? (vector-ref new-copy 3) (+ 1 cdayofmonth))) ;; if the month is specified and a match OR if the month is NOT specified (hash-table-set! all-times copy-now-secs new-copy)))))) (if cmin `(,cmin) ;; if given cmin, have to use it (list (- nmin 1) nmin (+ nmin 1))))) ;; minute (if chour `(,chour) (list (- nhour 1) nhour (+ nhour 1))))) ;; hour (if cdayofmonth `(,cdayofmonth) (list (- ndayofmonth 1) ndayofmonth (+ ndayofmonth 1))))) (if cmonth `(,cmonth) (list (- nmonth 1) nmonth (+ nmonth 1)))) (let ((before #f) (is-in #f)) (for-each (lambda (moment) (if (and before (<= before now-seconds) (>= moment now-seconds)) (begin ;; (print) ;; (print "Before: " (time->string (seconds->local-time before))) ;; (print "Now: " (time->string (seconds->local-time now-seconds))) ;; (print "After: " (time->string (seconds->local-time moment))) ;; (print "Last: " (time->string (seconds->local-time last-done))) (if (< last-done before) (set! is-in before)) )) (set! before moment)) (sort (hash-table-keys all-times) <)) is-in))))) (define (common:extended-cron cron-str now-seconds-in last-done) (let ((expanded-cron (common:cron-expand cron-str))) (if (string? expanded-cron) (common:cron-event expanded-cron now-seconds-in last-done) (let loop ((hed (car expanded-cron)) (tal (cdr expanded-cron))) (if (common:cron-event hed now-seconds-in last-done) #t (if (null? tal) #f (loop (car tal)(cdr tal)))))))) ;;====================================================================== ;; misc stuff ;;====================================================================== (define (common:get-signature str) (message-digest-string (md5-primitive) str)) ;;====================================================================== ;; 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)))) ;;====================================================================== ;; when called from a wrapper I need sometimes to find the calling ;; wrapper, this is for dashboard to find the correct megatest. ;; (define (common:find-local-megatest #!optional (progname "megatest")) (let ((res (filter file-exists? (map (lambda (updir) (let* ((lm (car (argv))) (dir (pathname-directory lm)) (exe (pathname-strip-directory lm))) (conc (if dir (conc dir "/") "") (case (string->symbol exe) ((dboard) (conc updir progname)) ((mtest) (conc updir progname)) ((dashboard) progname) (else exe))))) '("../../" "../"))))) (if (null? res) (begin ;; (debug:print 0 *default-log-port* "Failed to find this executable! Using what can be found on the path") progname) (car res)))) (define (common:generic-ssh ssh-command proc default #!optional (msg-proc #f)) (let ((inp #f)) (handle-exceptions exn (begin (close-input-port inp) (if msg-proc (msg-proc) (debug:print 0 *default-log-port* "Command: \""ssh-command"\" failed. exn="exn)) default) (set! inp (open-input-pipe ssh-command)) (with-input-from-port inp (lambda () (let ((res (proc))) (close-input-port inp) res)))))) ;; this is a close duplicate of: ;; process:alist-on-host? ;; process:alive ;; (define (commonmod:is-test-alive host pid) (let* ((same-host (equal? host (get-host-name))) (cmd (conc (if same-host "" (conc "ssh "host" ")) "pstree -A "pid))) (if (and host pid (not (equal? host "n/a"))) (let* ((output (if same-host (with-input-from-pipe cmd read-lines) (common:generic-ssh cmd read-lines '())))) ;; (with-input-from-pipe cmd read-lines))) (debug:print 2 *default-log-port* "Running " cmd " received " output) (if (eq? (length output) 0) #f #t)) #t))) ;; assuming bad query is about a live test is likely not the right thing to do? ) |
Modified configf.scm from [1a8a686afd] to [21beeb7ec6].
︙ | ︙ | |||
23 24 25 26 27 28 29 30 31 32 33 34 35 36 | ;;====================================================================== (use regex regex-case matchable) ;; directory-utils) (declare (unit configf)) (declare (uses process)) (declare (uses env)) (declare (uses keys)) (include "common_records.scm") ;; return list (path fullpath configname) (define (find-config configname #!key (toppath #f)) (if toppath (let ((cfname (conc toppath "/" configname))) | > > > > > > > > > > > > > > | 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 | ;;====================================================================== (use regex regex-case matchable) ;; directory-utils) (declare (unit configf)) (declare (uses process)) (declare (uses env)) (declare (uses keys)) (declare (uses debugprint)) (declare (uses mtargs)) (declare (uses mtargs.import)) (declare (uses common)) (declare (uses commonmod)) (declare (uses commonmod.import)) (declare (uses dbfile)) (declare (uses dbfile.import)) (declare (uses dbmod)) (declare (uses dbmod.import)) (import commonmod (prefix mtargs args:) debugprint) (include "common_records.scm") ;; return list (path fullpath configname) (define (find-config configname #!key (toppath #f)) (if toppath (let ((cfname (conc toppath "/" configname))) |
︙ | ︙ | |||
44 45 46 47 48 49 50 | (if (common:file-exists? fullpath) (list path fullpath configname) (let ((remcwd (take dir (- (length dir) 1)))) (if (null? remcwd) (list #f #f #f) ;; #f #f) (loop remcwd))))))))) | | > > > > | | | 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 | (if (common:file-exists? fullpath) (list path fullpath configname) (let ((remcwd (take dir (- (length dir) 1)))) (if (null? remcwd) (list #f #f #f) ;; #f #f) (loop remcwd))))))))) (define (configf:assoc-safe-add alist key val #!key (metadata #f)) (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist))) (append newalist (list (if metadata (list key val metadata) (list key val)))))) ;; this is used in megatestqa/ext.scm. ;; remove it from here and there by 12/31/21 ;; (define config:assoc-safe-add configf:assoc-safe-add) (define (configf:section-var-set! cfgdat section-name var value #!key (metadata #f)) (hash-table-set! cfgdat section-name (configf:assoc-safe-add (hash-table-ref/default cfgdat section-name '()) var value metadata: metadata))) (define (configf:eval-string-in-environment str) ;; (if (or (string-null? str) ;; (equal? "!" (substring str 0 1))) ;; null string or starts with ! are preserved but NOT set in the environment str (handle-exceptions exn (begin (debug:print-error 0 *default-log-port* "problem evaluating \"" str "\" in the shell environment, exn=" exn) |
︙ | ︙ | |||
92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 | (define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget|scm|sh|rp|gv|g|mtrah)\\s+([^\\}\\{]*)\\}(.*)")) (define (configf:system ht cmd) (system cmd) ) (define (configf:process-line l ht allow-system #!key (linenum #f)) (let loop ((res l)) (if (string? res) (let ((matchdat (string-search configf:var-expand-regex res))) (if matchdat (let* ((prestr (list-ref matchdat 1)) (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv (cmd (list-ref matchdat 3)) (poststr (list-ref matchdat 4)) (result #f) (start-time (current-seconds)) (cmdsym (string->symbol cmdtype)) (fullcmd (case cmdsym | > > | | 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 | (define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget|scm|sh|rp|gv|g|mtrah)\\s+([^\\}\\{]*)\\}(.*)")) (define (configf:system ht cmd) (system cmd) ) (define configf:imports "(import commonmod (prefix mtargs args:))") (define (configf:process-line l ht allow-system #!key (linenum #f)) (let loop ((res l)) (if (string? res) (let ((matchdat (string-search configf:var-expand-regex res))) (if matchdat (let* ((prestr (list-ref matchdat 1)) (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv (cmd (list-ref matchdat 3)) (poststr (list-ref matchdat 4)) (result #f) (start-time (current-seconds)) (cmdsym (string->symbol cmdtype)) (fullcmd (case cmdsym ((scheme scm) (conc "(lambda (ht)(begin " configf:imports cmd "))")) ((system) (conc "(lambda (ht)(configf:system ht \"" cmd "\"))")) ((shell sh) (conc "(lambda (ht)(string-translate (shell \"" cmd "\") \"\n\" \" \"))")) ((realpath rp)(conc "(lambda (ht)(common:nice-path \"" cmd "\"))")) ((getenv gv) (conc "(lambda (ht)(get-environment-variable \"" cmd "\"))")) ((mtrah) (conc "(lambda (ht)" " (let ((extra \"" cmd "\"))" " (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\"))" |
︙ | ︙ | |||
142 143 144 145 146 147 148 | (lambda () (set! result ((eval (read)) ht)))) (set! result (conc "#{(" cmdtype ") " cmd "}")))) (case cmdsym ((system shell scheme) (let ((delta (- (current-seconds) start-time))) (if (> delta 2) | | | | 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 | (lambda () (set! result ((eval (read)) ht)))) (set! result (conc "#{(" cmdtype ") " cmd "}")))) (case cmdsym ((system shell scheme) (let ((delta (- (current-seconds) start-time))) (if (> delta 2) (debug:print-info 2 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result) (debug:print-info 9 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result))))) (loop (conc prestr result poststr))) res)) res))) ;; Run a shell command and return the output as a string (define (shell cmd) (let* ((output (process:cmd-run->list cmd)) (res (car output)) (status (cadr output))) (if (equal? status 0) (let ((outres (string-intersperse res "\n"))) (debug:print-info 4 *default-log-port* "shell result:\n" outres) outres) (begin ;; why is this printing to error-port and not using debug:print? -mrw- (with-output-to-port (current-error-port) (lambda () (print "ERROR: " cmd " returned bad exit code " status))) "")))) ;; this was inline but I'm pretty sure that is a hold over from when it was *very* simple ... ;; |
︙ | ︙ | |||
239 240 241 242 243 244 245 | (if (and (not same-section) rx-match) (for-each (lambda (bundle) ;; (print "bundle: " bundle) (let ((key (car bundle)) (val (cadr bundle)) (meta (if (> (length bundle) 2)(caddr bundle) #f))) | | | 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 | (if (and (not same-section) rx-match) (for-each (lambda (bundle) ;; (print "bundle: " bundle) (let ((key (car bundle)) (val (cadr bundle)) (meta (if (> (length bundle) 2)(caddr bundle) #f))) (hash-table-set! ht section (configf:assoc-safe-add (hash-table-ref ht section) key val metadata: meta)))) vars))))) (hash-table-keys ht)))) ht) ;; read a config file, returns hash table of alists ;; read a config file, returns hash table of alists |
︙ | ︙ | |||
417 418 419 420 421 422 423 | (if (> delta 2) (debug:print-info 0 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res) (debug:print-info 9 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)) (if (null? res) "" (string-intersperse res " ")))))) (hash-table-set! res curr-section-name | | | | | | | 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 | (if (> delta 2) (debug:print-info 0 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res) (debug:print-info 9 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)) (if (null? res) "" (string-intersperse res " ")))))) (hash-table-set! res curr-section-name (configf:assoc-safe-add alist key (case (calc-allow-system allow-system curr-section-name sections) ((return-procs) val-proc) ((return-string) cmd) (else (val-proc))) metadata: metapath)) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))) (configf:key-no-val ( x key val) (let* ((alist (hash-table-ref/default res curr-section-name '())) (fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces) (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = #t") (safe-setenv key fval) (hash-table-set! res curr-section-name (configf:assoc-safe-add alist key fval metadata: metapath)) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name key #f))) (configf:key-val-pr ( x key unk1 val unk2 ) (let* ((alist (hash-table-ref/default res curr-section-name '())) (envar (and environ-patt (string-search (regexp environ-patt) curr-section-name) ;; does the section match the envionpatt? (and (not (string-null? key)) (not (equal? "!" (substring key 0 1)))) ;; ! as leading character is a signature to NOT export to the environment ;; (string-match "^.*:.*:.*$" key) ;; ;; something:something:something reserved for triggers in runconfigs )) (realval (if envar (configf:eval-string-in-environment val) val))) (debug:print-info 6 *default-log-port* "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) (if envar (safe-setenv key realval)) (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = " val) (hash-table-set! res curr-section-name (configf:assoc-safe-add alist key realval metadata: metapath)) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name key #f))) ;; if a continued line (configf:cont-ln-rx ( x whsp val ) (let ((alist (hash-table-ref/default res curr-section-name '()))) (if var-flag ;; if set to a string then we have a continued var (let ((newval (conc (configf:lookup res curr-section-name var-flag) "\n" ;; trim lead from the incoming whsp to support some indenting. (if lead (string-substitute (regexp lead) "" whsp) "") val))) ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag) (hash-table-set! res curr-section-name (configf:assoc-safe-add alist var-flag newval metadata: metapath)) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp))) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) (else (debug:print-error 0 *default-log-port* "problem parsing " path ",\n \"" inl "\"") (set! var-flag #f) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) ) ;; end loop ))) |
︙ | ︙ | |||
522 523 524 525 526 527 528 529 530 531 532 533 534 535 | ;; var yes ;; ;; (configf:var-is? cfgdat "foo" "var" "yes") => #t ;; (define (configf:var-is? cfgdat section var expected-val) (equal? (configf:lookup cfgdat section var) expected-val)) (define config-lookup configf:lookup) (define configf:read-file read-config) ;; safely look up a value that is expected to be a number, return ;; a default (#f unless provided) ;; (define (configf:lookup-number cfgdat section varname #!key (default #f)) | > | 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 | ;; var yes ;; ;; (configf:var-is? cfgdat "foo" "var" "yes") => #t ;; (define (configf:var-is? cfgdat section var expected-val) (equal? (configf:lookup cfgdat section var) expected-val)) ;; redefines (define config-lookup configf:lookup) (define configf:read-file read-config) ;; safely look up a value that is expected to be a number, return ;; a default (#f unless provided) ;; (define (configf:lookup-number cfgdat section varname #!key (default #f)) |
︙ | ︙ | |||
550 551 552 553 554 555 556 | (define (configf:get-section cfgdat section) (hash-table-ref/default cfgdat section '())) (define (configf:set-section-var cfgdat section var val) (let ((sectdat (configf:get-section cfgdat section))) (hash-table-set! cfgdat section | | > | | | 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 | (define (configf:get-section cfgdat section) (hash-table-ref/default cfgdat section '())) (define (configf:set-section-var cfgdat section var val) (let ((sectdat (configf:get-section cfgdat section))) (hash-table-set! cfgdat section (configf:assoc-safe-add sectdat var val)))) ;;====================================================================== ;;(append (filter (lambda (x)(not (assoc var sectdat))) sectdat) ;; (list var val)))) (define (setup) (let* ((configf (find-config "megatest.config")) (config (if configf (read-config configf #f #t) #f))) (if config (setenv "RUN_AREA_HOME" (pathname-directory configf))) config)) |
︙ | ︙ | |||
779 780 781 782 783 784 785 | ht)) ;; if (define (configf:read-alist fname) (handle-exceptions exn (begin | | | 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 | ht)) ;; if (define (configf:read-alist fname) (handle-exceptions exn (begin (debug:print 0 *default-log-port* "read of alist " fname " failed. exn=" exn) #f) (configf:alist->config (with-input-from-file fname read)))) (define (configf:write-alist cdat fname) (if (not (common:faux-lock fname)) (debug:print 0 *default-log-port* "INFO: Could not get lock on " fname)) |
︙ | ︙ |
Added configfmod.scm version [150f2301e2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;;====================================================================== ;; 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 configfmod)) ;; (declare (uses mtargs)) ;; (declare (uses debugprint)) ;; (declare (uses keysmod)) (module configfmod * (import srfi-1 ;; scheme ;; ;; big-chicken ;; more of a reminder than anything ... ;; chicken.base ;; chicken.condition ;; chicken.file ;; chicken.io ;; chicken.pathname ;; chicken.port ;; chicken.pretty-print ;; chicken.process ;; chicken.process-context ;; chicken.process-context.posix ;; chicken.sort ;; chicken.string ;; chicken.time ;; chicken.eval ;; ;; debugprint ;; (prefix mtargs args:) ;; pkts ;; keysmod ;; ;; (prefix base64 base64:) ;; (prefix dbi dbi:) ;; (prefix sqlite3 sqlite3:) ;; (srfi 18) ;; directory-utils ;; format ;; matchable ;; md5 ;; message-digest ;; regex ;; regex-case ;; sparse-vectors ;; srfi-1 ;; srfi-13 ;; srfi-69 ;; stack ;; typed-records ;; z3 ) ) |
Modified configure from [5bc39a4917] to [08e182d3ee].
︙ | ︙ | |||
69 70 71 72 73 74 75 | if [[ -e /usr/bin/sw_vers ]]; then ARCHSTR=$(/usr/bin/sw_vers -productVersion) else ARCHSTR=$(lsb_release -sr) fi | | | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 | if [[ -e /usr/bin/sw_vers ]]; then ARCHSTR=$(/usr/bin/sw_vers -productVersion) else ARCHSTR=$(lsb_release -sr) fi echo "CHICKEN_PREFIX=$PREFIX/.$ARCHSTR" >> makefile.inc CHICKEN_PREFIX=$PREFIX/bin/.$ARCHSTR if [[ ! $(type csi) ]];then echo "Chicken build needed." echo "BUILD_CHICKEN=yes" >> makefile.inc configure_dependencies echo "include chicken.makefile" >> makefile.inc |
︙ | ︙ |
Modified dashboard-context-menu.scm from [48947370a7] to [8f34d70b32].
︙ | ︙ | |||
19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | ;;====================================================================== ;;====================================================================== ;; implementation of context menu that pops up on ;; right click on test cell in Runs & Runs Summary Tabs ;;====================================================================== (use format fmt) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) (use srfi-1 posix regex regex-case srfi-69) (use (prefix sqlite3 sqlite3:)) | > > > > > > > > > > > > < < < < < < < < < < > > > > | 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 | ;;====================================================================== ;;====================================================================== ;; implementation of context menu that pops up on ;; right click on test cell in Runs & Runs Summary Tabs ;;====================================================================== (declare (unit dashboard-context-menu)) (declare (uses common)) (declare (uses commonmod)) (declare (uses db)) (declare (uses gutils)) (declare (uses rmt)) (declare (uses rmtmod)) (declare (uses ezsteps)) ;; (declare (uses sdb)) ;; (declare (uses filedb)) (declare (uses subrun)) (use format fmt) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) (use srfi-1 posix regex regex-case srfi-69) (use (prefix sqlite3 sqlite3:)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") (import commonmod rmtmod debugprint) (define (dboard:launch-testpanel run-id test-id) (let* ((dboardexe (common:find-local-megatest "dashboard")) (cmd (conc dboardexe " -test " run-id "," test-id " &"))) (system cmd))) |
︙ | ︙ | |||
317 318 319 320 321 322 323 | (runs:get-mt-env-alist run-id run-name target test-name item-path) (lambda () (if scheme-match (begin (handle-exceptions exn | | | 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 | (runs:get-mt-env-alist run-id run-name target test-name item-path) (lambda () (if scheme-match (begin (handle-exceptions exn (debug:print 0 *default-log-port* "error with custom menu scheme, exn=" exn) (begin ;;(BB> "gonna eval it!") (eval (with-input-from-string (cadr scheme-match) read))))) (common:run-a-command command-line with-vars: #t)))))))) #f))) vars))) |
︙ | ︙ |
Modified dashboard-guimonitor.scm from [9920d4908c] to [76c7fb97a3].
︙ | ︙ | |||
32 33 34 35 36 37 38 39 40 41 42 43 44 45 | (import (prefix sqlite3 sqlite3:)) (declare (unit dashboard-guimonitor)) (declare (uses common)) (declare (uses keys)) (declare (uses db)) (declare (uses tasks)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") (include "task_records.scm") (define (control-panel db tdb keys) | > > | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 | (import (prefix sqlite3 sqlite3:)) (declare (unit dashboard-guimonitor)) (declare (uses common)) (declare (uses keys)) (declare (uses db)) (declare (uses tasks)) (declare (uses commonmod)) (import commonmod) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") (include "task_records.scm") (define (control-panel db tdb keys) |
︙ | ︙ | |||
72 73 74 75 76 77 78 | (iup:frame #:title "Runs" (iup:hbox (iup:button "Start" #:expand "HORIZONTAL" #:action (lambda (obj) (tasks:add-from-params tdb "run" keys key-params var-params) | | > | | | 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 | (iup:frame #:title "Runs" (iup:hbox (iup:button "Start" #:expand "HORIZONTAL" #:action (lambda (obj) (tasks:add-from-params tdb "run" keys key-params var-params) ;; (print "Launch Run") )) (iup:button "Remove" #:expand "HORIZONTAL" #:action (lambda (obj) ;; (print "Remove Run") (tasks:add-from-params tdb "remove" keys key-params var-params) )) (iup:button "Rollup" #:expand "HORIZONTAL" #:action (lambda (obj) ;; (print "Rollup Run") (tasks:add-from-params tdb "rollup" keys key-params var-params))))) (iup:frame #:title "Misc" (iup:hbox (iup:button "Quit" #:expand "HORIZONTAL" #:action (lambda (obj) |
︙ | ︙ |
Modified dashboard-tests.scm from [e1041b5905] to [9ace3eb7d8].
︙ | ︙ | |||
18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | ;;====================================================================== ;;====================================================================== ;; Test info panel ;;====================================================================== (use format fmt) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) (use srfi-1 posix regex regex-case srfi-69) (use (prefix sqlite3 sqlite3:)) | > > > > > > > > > > > > < | < < | | < < < | 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 | ;;====================================================================== ;;====================================================================== ;; Test info panel ;;====================================================================== (declare (unit dashboard-tests)) (declare (uses common)) (declare (uses commonmod)) (declare (uses dcommon)) (declare (uses db)) (declare (uses gutils)) (declare (uses rmt)) (declare (uses ezsteps)) (declare (uses subrun)) (declare (uses debugprint)) (declare (uses rmtmod)) (use format fmt) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) (use srfi-1 posix regex regex-case srfi-69) (use (prefix sqlite3 sqlite3:)) (import commonmod rmtmod debugprint) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") ;;====================================================================== ;; C O M M O N |
︙ | ︙ | |||
87 88 89 90 91 92 93 | (list "Testname: " "Item path: " "Current state: " "Current status: " "Test comment: " "Test id: " "Test date: ")) | | > | 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 | (list "Testname: " "Item path: " "Current state: " "Current status: " "Test comment: " "Test id: " "Test date: ")) (list (iup:label "" #:expand "VERTICAL" )))) (apply iup:vbox ; #:expand "YES" (list (store-label "testname" (iup:label (db:test-get-testname testdat) #:expand "HORIZONTAL") (lambda (testdat)(db:test-get-testname testdat))) (store-label "item-path" (iup:label (db:test-get-item-path testdat) #:expand "HORIZONTAL") |
︙ | ︙ | |||
155 156 157 158 159 160 161 | (iup:label val ; #:expand "HORIZONTAL" )) (list "Author: " "Owner: " "Reviewed: " "Tags: " "Description: ")) | | > | > | 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 | (iup:label val ; #:expand "HORIZONTAL" )) (list "Author: " "Owner: " "Reviewed: " "Tags: " "Description: ")) (list (iup:label "" #:expand "VERTICAL" )))) (apply iup:vbox ; #:expand "YES" (list (store-meta "author" (iup:label (db:testmeta-get-author testmeta) #:expand "HORIZONTAL") (lambda (testmeta)(db:testmeta-get-author testmeta))) (store-meta "owner" (iup:label (db:testmeta-get-owner testmeta) #:expand "HORIZONTAL") (lambda (testmeta)(db:testmeta-get-owner testmeta))) (store-meta "reviewed" (iup:label (db:testmeta-get-reviewed testmeta) #:expand "HORIZONTAL") (lambda (testmeta)(db:testmeta-get-reviewed testmeta))) (store-meta "tags" (iup:label (db:testmeta-get-tags testmeta) #:expand "HORIZONTAL") (lambda (testmeta)(db:testmeta-get-tags testmeta))) (store-meta "description" (iup:label (test-meta-panel-get-description testmeta) ;; #:wordwrap "YES" ;; #:size "x50" ) ;; #:expand "HORIZONTAL") (lambda (testmeta) (test-meta-panel-get-description testmeta))) ))))) ;;====================================================================== ;; Run info panel |
︙ | ︙ | |||
199 200 201 202 203 204 205 | (iup:label (conc (car keyval) " "))) keydat) (list (iup:label "runname ") (iup:label "run-id") (iup:label "run-date")))) (apply iup:vbox (append (map (lambda (keyval) | > | > > > | > | > | 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 | (iup:label (conc (car keyval) " "))) keydat) (list (iup:label "runname ") (iup:label "run-id") (iup:label "run-date")))) (apply iup:vbox (append (map (lambda (keyval) (iup:vbox (iup:label (cadr keyval) #:expand "HORIZONTAL") ;; (iup:label "" #:expand "BOTH") ) ) keydat) (list (iup:label runname) (iup:label (conc run-id)) (iup:label (seconds->year-work-week/day-time event_time)) (iup:label "" ;;#:expand "VERTICAL" )))))))) ;;====================================================================== ;; Host info panel ;;====================================================================== (define (host-info-panel testdat store-label) (iup:frame #:title "Remote host and Test Run Info" ; #:expand "YES" (iup:hbox ; #:expand "YES" (apply iup:vbox ; #:expand "YES" ;; The heading labels (append (map (lambda (val) (iup:label val ; #:expand "HORIZONTAL" )) (list "Hostname: " "Disk free: " "CPU Load: " "Run duration: " "Logfile: " "Top process id: " "Uname -a: ")) (iup:label "" ;; #:expand "VERTICAL" ))) (apply iup:vbox ; #:expand "YES" (list ;; NOTE: Yes, the host can change! (store-label "HostName" (iup:label ;; (sdb:qry 'getstr (db:test-get-host testdat) ;; ) #:expand "HORIZONTAL") |
︙ | ︙ | |||
259 260 261 262 263 264 265 | ))))) ;; if there is a submegatest create a button to launch dashboard in that area ;; (define (submegatest-panel dbstruct keydat testdat runname testconfig) (let* ((test-run-dir (db:test-get-rundir testdat)) (subarea (subrun:get-runarea test-run-dir)) | | < < < < < < < < < < < | | | | | | | | < < | | | 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 | ))))) ;; if there is a submegatest create a button to launch dashboard in that area ;; (define (submegatest-panel dbstruct keydat testdat runname testconfig) (let* ((test-run-dir (db:test-get-rundir testdat)) (subarea (subrun:get-runarea test-run-dir)) (area-exists (and subarea (common:file-exists? subarea silent: #t)))) (iup:frame #:title "Megatest Run Info" ;; #:expand "HORIZONTAL" (if subarea (iup:button "Launch Dashboard" #:action (lambda (obj) (subrun:launch-dashboard test-run-dir))) (iup:vbox (iup:label "Not a subrun..." #:expand "HORIZONTAL") ))))) ;; use a global for setting the buttons colors ;; state status teststeps (define *state-status* (vector #f #f #f)) (define (update-state-status-buttons testdat) (let* ((state (db:test-get-state testdat)) (status (db:test-get-status testdat)) |
︙ | ︙ | |||
337 338 339 340 341 342 343 | (map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ")))) (vector-set! *state-status* 0 (lambda (state color) (for-each (lambda (btn) (let* ((name (iup:attribute btn "TITLE")) (newcolor (if (equal? name state) color "192 192 192"))) | | | | 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 | (map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ")))) (vector-set! *state-status* 0 (lambda (state color) (for-each (lambda (btn) (let* ((name (iup:attribute btn "TITLE")) (newcolor (if (equal? name state) color "192 192 192"))) (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) (iup:attribute-set! btn "BGCOLOR" newcolor)))) btns))) btns)) (apply iup:hbox (iup:label "STATUS:" #:size "30x") (let* ((btns (map (lambda (status) (let ((btn (iup:button status #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" |
︙ | ︙ | |||
371 372 373 374 375 376 377 | (map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) (vector-set! *state-status* 1 (lambda (status color) (for-each (lambda (btn) (let* ((name (iup:attribute btn "TITLE")) (newcolor (if (equal? name status) color "192 192 192"))) | | | | 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 | (map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) (vector-set! *state-status* 1 (lambda (status color) (for-each (lambda (btn) (let* ((name (iup:attribute btn "TITLE")) (newcolor (if (equal? name status) color "192 192 192"))) (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) (iup:attribute-set! btn "BGCOLOR" newcolor)))) btns))) btns)))))) (define (dashboard-tests:run-a-step info) #t) ;; (define (dashboard-tests:step-run-control testdat stepname testconfig) |
︙ | ︙ | |||
471 472 473 474 475 476 477 | dlog)) ;;====================================================================== ;; ;;====================================================================== (define (dashboard-tests:examine-test run-id test-id) ;; run-id run-key origtest) | | | < | 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 | dlog)) ;;====================================================================== ;; ;;====================================================================== (define (dashboard-tests:examine-test run-id test-id) ;; run-id run-key origtest) (let* ((db-path (common:make-tmpdir-name *toppath* "")) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db")) (dbstruct #f) ;; NOT USED (testdat (rmt:get-test-info-by-id run-id test-id)) ;; (db:get-test-info-by-id dbstruct run-id test-id)) (db-mod-time 0) ;; (file-modification-time db-path)) (last-update 0) ;; (current-seconds)) (request-update #t)) (if (not testdat) (begin (debug:print 2 *default-log-port* "ERROR: No test data found for test " test-id ", exiting") |
︙ | ︙ | |||
679 680 681 682 683 684 685 686 687 688 689 690 691 692 | (iup:attribute-set! command-text-box "VALUE" (conc "megatest -target " keystring " -runname " runname " -run -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) " -clean-cache" )))) (remove-test (lambda (x) (iup:attribute-set! command-text-box "VALUE" (conc "megatest -remove-runs -target " keystring " -runname " runname " -testpatt " (conc testname "/" (if (equal? item-path "") "%" | > > > > > > > > > | 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 | (iup:attribute-set! command-text-box "VALUE" (conc "megatest -target " keystring " -runname " runname " -run -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) " -clean-cache" )))) (rerun-clean (lambda (x) (iup:attribute-set! command-text-box "VALUE" (conc "megatest -target " keystring " -runname " runname " -rerun-clean -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) " -clean-cache" )))) (remove-test (lambda (x) (iup:attribute-set! command-text-box "VALUE" (conc "megatest -remove-runs -target " keystring " -runname " runname " -testpatt " (conc testname "/" (if (equal? item-path "") "%" |
︙ | ︙ | |||
720 721 722 723 724 725 726 | command-text-box "VALUE" (conc "megatest -target " keystring " -runname " runname " -archive save-remove -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) ))))) (cond | | | > > | | | | | | | | | | | | > > | > > > > > | > | < | > > > > | | > | 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 | command-text-box "VALUE" (conc "megatest -target " keystring " -runname " runname " -archive save-remove -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) ))))) (cond ((not testdat)(begin (debug:print 0 *default-log-port* "ERROR: bad test info for " test-id)(exit 1))) ((not rundat)(begin (debug:print 0 *default-log-port* "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1))) (else ;; (test-set-status! db run-id test-name state status itemdat) (set! self ; (iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES" #:title testfullname (iup:vbox (iup:hbox (iup:vbox ; #:expand "YES" ;; The run and test info (iup:hbox ; #:expand "YES" (run-info-panel dbstruct keydat testdat runname) (test-info-panel testdat store-label widgets)) (host-info-panel testdat store-label)) (iup:vbox (test-meta-panel testmeta store-meta) (submegatest-panel dbstruct keydat testdat runname testconfig))) ;; The controls (iup:hbox ;; frame #:title "Actions" (iup:vbox (iup:hbox (iup:frame #:title "Immediate" (iup:hbox (iup:button "Start Xterm" #:action xterm #:size "80x") (iup:button "CleanRunExecute!" #:action clean-run-execute #:size "80x") (iup:button "View Log" #:action viewlog #:size "80x"))) (iup:frame #:title "Command line" (iup:hbox (iup:button "Run Test" #:action run-test #:size "80x") (iup:button "Rerun-clean" #:action rerun-clean #:size "80x") (iup:button "Clean Test" #:action remove-test #:size "80x") (iup:button "Kill All Jobs" #:action kill-jobs #:size "80x"))) (iup:label "" #:expand "HORIZONTAL") (iup:frame #:title "Other" (iup:hbox ;; (iup:button "Archive Test" #:action archive-test #:size "80x") (iup:button "Close" #:action (lambda (x)(exit)) #:size "80x") ))) (apply iup:hbox (list command-text-box command-launch-button)))) (set-fields-panel dbstruct run-id test-id testdat) (let ((tabs (iup:tabs ;; Replace here with matrix |
︙ | ︙ | |||
770 771 772 773 774 775 776 | #:click-cb (lambda (obj lin col status) ;; (if (equal? col 6) (let* ((mtrx-rc (conc lin ":" 6)) (fname (iup:attribute obj mtrx-rc)) (stepname (iup:attribute obj (conc lin ":" 1))) (comment (iup:attribute obj (conc lin ":" 7)))) (case col | | | 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 | #:click-cb (lambda (obj lin col status) ;; (if (equal? col 6) (let* ((mtrx-rc (conc lin ":" 6)) (fname (iup:attribute obj mtrx-rc)) (stepname (iup:attribute obj (conc lin ":" 1))) (comment (iup:attribute obj (conc lin ":" 7)))) (case col ((7) (debug:print 0 *default-log-port* "Comment from step "stepname": "comment)) ((8) (ezsteps:spawn-run-from testdat stepname #t)) ((9) (ezsteps:spawn-run-from testdat stepname #f)) (else (view-a-log fname)))))))) ;; (let loop ((count 0)) ;; (iup:attribute-set! steps-matrix "FITTOTEXT" (conc "L" count)) ;; (if (< count 30) ;; (loop (+ count 1)))) |
︙ | ︙ |
Added dashboard-transport-mode.scm version [a7eb4115fd].
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | ;;====================================================================== ;; set up transport, db cache and sync methods ;; ;; sync-method: 'original, 'attach or 'none ;; cache-method: 'tmp or 'none ;; rmt:transport-mode: 'http, 'tcp, 'nfs ;; ;; NOTE: NOT ALL COMBINATIONS WORK ;; ;;====================================================================== ;; uncomment this block to test without tcp or cachedb ;; (dbfile:sync-method 'none) ;; (dbfile:cache-method 'none) ;; (rmt:transport-mode 'nfs) ;; uncomment this block to test with tcp and cachedb (dbfile:sync-method 'none) ;; original was causing crash on start. (dbfile:cache-method 'none) (rmt:transport-mode 'nfs) |
Added dashboard-transport-mode.scm.template version [a7eb4115fd].
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | ;;====================================================================== ;; set up transport, db cache and sync methods ;; ;; sync-method: 'original, 'attach or 'none ;; cache-method: 'tmp or 'none ;; rmt:transport-mode: 'http, 'tcp, 'nfs ;; ;; NOTE: NOT ALL COMBINATIONS WORK ;; ;;====================================================================== ;; uncomment this block to test without tcp or cachedb ;; (dbfile:sync-method 'none) ;; (dbfile:cache-method 'none) ;; (rmt:transport-mode 'nfs) ;; uncomment this block to test with tcp and cachedb (dbfile:sync-method 'none) ;; original was causing crash on start. (dbfile:cache-method 'none) (rmt:transport-mode 'nfs) |
Modified dashboard.scm from [4fa36f8fdd] to [89bc431aeb].
︙ | ︙ | |||
14 15 16 17 18 19 20 | ;; 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/>. ;; ;;====================================================================== | < | < < | < < < < < | | | | | < | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < | | < < < < < < > > > > > > | < < < > < | < < < | | < > < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < | < < < < < < | | < < < < < < < < < | < < < | < < < | | > > | | | | | | | | | < | > > | | | | | | | | | > | > > > > > > > > > > > | < < < | > > > | | | | | | | > > > > > > > > > > > > > > | | < > > | < > > | < | | > > > > | | 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 | ;; 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 (uses common)) (declare (uses mtargs)) (declare (uses mtargs.import)) (declare (uses keys)) (declare (uses items)) (declare (uses debugprint)) (declare (uses debugprint.import)) (declare (uses db)) (declare (uses configf)) (declare (uses process)) (declare (uses launch)) (declare (uses runs)) (declare (uses dashboard-tests)) (declare (uses tree)) (declare (uses dcommon)) (declare (uses dashboard-context-menu)) (declare (uses vg)) (declare (uses subrun)) (declare (uses mt)) (declare (uses dbmod)) (declare (uses dbfile)) (declare (uses dbfile.import)) (declare (uses rmtmod)) (declare (uses rmtmod.import)) (declare (uses commonmod)) (declare (uses commonmod.import)) (use format) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) (import canvas-draw-iup (prefix sqlite3 sqlite3:)) (use ducttape-lib) (use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct (import commonmod (prefix mtargs args:) dbmod dbfile rmtmod debugprint) (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") ;; set some parameters here - these need to be put in something that can be loaded from other ;; executables such as dashboard and mtutil ;; (include "dashboard-transport-mode.scm") (dbfile:db-init-proc db:initialize-main-db) (set! rmtmod:send-receive rmt:send-receive) (debug:print-info 0 *default-log-port* "transport-mode="(rmt:transport-mode)) (define help (conc "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright (C) Matt Welland 2012-2017 Usage: dashboard [options] -h : this help -test run-id test-id : open a test control panel on this test -skip-version-check : skip the version check -rows R : set number of rows -cols C : set number of columns -start-dir dir : start dashboard in the given directory -target target : filter runs tab to given target. -debug n[,n] : set debug level(s) e.g. -debug 4 or -debug 0,9 -repl : Start a chicken scheme interpreter -mode MODE : tcp or nfs " )) ;; process args (define remargs (args:get-args (argv) ;; parameters (need arguments) (list "-rows" "-cols" "-test" ;; given a run id and test id, open only a test control panel on that test.. "-debug" "-start-dir" "-target" "-mode" ;; tcp or nfs ) ;; switches (don't take arguments) (list "-h" "-skip-version-check" "-repl" "-:p" ;; ignore the built in chicken profiling switch ) args:arg-hash 0)) (if (args:get-arg "-mode") (let* ((mode (string->symbol (args:get-arg "-mode")))) (rmt:transport-mode mode))) ;; (rmt:transport-mode 'tcp)) (if (args:get-arg "-test") ;; need to use tcp for test control panel (rmt:transport-mode 'tcp)) ;; RA => Might require revert for filters ;; create a watch dog to move changes from lt/.db/*.db to megatest.db ;; ;;;(if (file-write-access? (conc *toppath* "/megatest.db")) ;;(debug:print-info 13 *default-log-port* "Before common:watchdog spawn") ;; (thread-start! (make-thread common:watchdog "Watchdog thread")) ;;(debug:print-info 13 *default-log-port* "After common:watchdog spawn") ;; (if (not (args:get-arg "-use-db-cache")) ;; (begin ;; (debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db") ;; (hash-table-set! args:arg-hash "-use-db-cache" #t)));;;) ;;) ;; data common to all tabs goes here ;; ;; Moved to dcommon.scm ;; ;; (defstruct dboard:commondat ;; ((curr-tab-num 0) : number) ;; please-update ;; tabdats ;; update-mutex ;; updaters ;; updating ;; uidat ;; needs to move to tabdat at some time ;; hide-not-hide-tabs ;; target ;; ) ;; ;; (define (dboard:commondat-make) ;; (make-dboard:commondat ;; curr-tab-num: 0 ;; tabdats: (make-hash-table) ;; please-update: #t ;; update-mutex: (make-mutex) ;; updaters: (make-hash-table) ;; updating: #f ;; hide-not-hide-tabs: #f ;; target: "" ;; )) (set! *journal-stats-enable* #f) ;;====================================================================== ;; buttons color using image ;;====================================================================== (define *images* (make-hash-table)) (define (make-image images name color) (if (hash-table-exists? images name) name (let* ((img-bits1 (u8vector->blob (u8vector 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ))) ;; w h (img1 (iup:image/palette 16 24 img-bits1))) (iup:handle-name-set! img1 name) ;; (iup:attribute-set! img1 "0" "0 0 0") (iup:attribute-set! img1 "1" color) ;; "BGCOLOR") ;; (iup:attribute-set! img1 "2" "255 0 0") (hash-table-set! images name img1) name))) ;; gets and calls updater list based on curr-tab-num ;; (define (dboard:common-run-curr-updaters commondat #!key (tab-num #f)) ;; (sync-db-to-tmp (dboard:common-get-tabdat commondat tab-num: tab-num)) ;; no longer applies ;; maybe need sleep here? (if (dboard:common-get-tabdat commondat tab-num: tab-num) ;; only update if there is a tabdat (let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat))) (updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '()))) (debug:print 4 *default-log-port* "Found these updaters: " updaters " for tab-num: " tnum) (for-each ;; perform the function calls for the complete updaters list (lambda (updater) ;; (debug:print 3 *default-log-port* "Running " updater) (updater)) updaters)))) ;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num ;; adds the updater passed in the updaters list at that hashkey ;; (define (dboard:commondat-add-updater commondat updater #!key (tab-num #f)) |
︙ | ︙ | |||
355 356 357 358 359 360 361 | ;; runs summary view tests-tree ;; used in newdashboard ) ;; register tabdat with BBpp ;; this is used by BBpp (Brandon's pretty printer) to convert dboard:tabdat into a composition of lists that pp will handle | | | | | | | | | | 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 | ;; runs summary view tests-tree ;; used in newdashboard ) ;; register tabdat with BBpp ;; this is used by BBpp (Brandon's pretty printer) to convert dboard:tabdat into a composition of lists that pp will handle ;; (hash-table-set! *BBpp_custom_expanders_list* TABDAT: ;; (cons dboard:tabdat? ;; (lambda (tabdat-item) ;; (filter ;; (lambda (alist-entry) ;; (member (car alist-entry) ;; '(allruns-by-id allruns))) ;; FIELDS OF INTEREST ;; (dboard:tabdat->alist tabdat-item))))) (define (dboard:tabdat-target-string vec) (let ((targ (dboard:tabdat-target vec))) (if (list? targ)(string-intersperse targ "/") "no-target-specified"))) |
︙ | ︙ | |||
384 385 386 387 388 389 390 | (define (dboard:tabdat-make-data) (let ((dat (make-dboard:tabdat))) (dboard:setup-tabdat dat) (dboard:setup-num-rows dat) dat)) (define (dboard:setup-tabdat tabdat) | | | > < | 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 | (define (dboard:tabdat-make-data) (let ((dat (make-dboard:tabdat))) (dboard:setup-tabdat dat) (dboard:setup-num-rows dat) dat)) (define (dboard:setup-tabdat tabdat) (dboard:tabdat-dbdir-set! tabdat (common:make-tmpdir-name *toppath* "")) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) (dboard:tabdat-dbfpath-set! tabdat (common:make-tmpdir-name *toppath* "")) (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db")) ;; HACK ALERT: this is a hack, please fix. (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat)))) (dboard:tabdat-keys-set! tabdat (rmt:get-keys)) (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname"))) (dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%")) ) ;; RADT => Matrix defstruct addition (defstruct dboard:graph-dat |
︙ | ︙ | |||
419 420 421 422 423 424 425 | (define (dboard:runsdat-make-init) (make-dboard:runsdat runs-index: (make-hash-table) tests-index: (make-hash-table) matrix-dat: (make-sparse-array))) | > > | | | | | | | | | | | | | | | | | | 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 | (define (dboard:runsdat-make-init) (make-dboard:runsdat runs-index: (make-hash-table) tests-index: (make-hash-table) matrix-dat: (make-sparse-array))) ;; duplicated in dcommon.scm ;; ;; ;; used to keep the rundata from rmt:get-tests-for-run ;; ;; in sync. ;; ;; ;; (defstruct dboard:rundat ;; run ;; tests-drawn ;; list of id's already drawn on screen ;; tests-notdrawn ;; list of id's NOT already drawn ;; rowsused ;; hash of lists covering what areas used - replace with quadtree ;; hierdat ;; put hierarchial sorted list here ;; tests ;; hash of id => testdat ;; ((tests-by-name (make-hash-table)) : hash-table) ;; hash of testfullname => testdat ;; key-vals ;; ((last-update 0) : number) ;; last query to db got records from before last-update ;; ((last-db-time 0) : number) ;; last timestamp on main.db ;; ((data-changed #f) : boolean) ;; ((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less than 100 items ;; (db-path #f)) ;; for the new runs view lets build up a few new record types and then consolidate later ;; ;; this is a two level deep pipeline for the incoming data: ;; sql query data ==> filters ==> data for display ;; (defstruct dboard:rdat |
︙ | ︙ | |||
505 506 507 508 509 510 511 | status start-time duration ) ;; register dboard:rundat with BBpp ;; this is used by BBpp (Brandon's pretty printer) to convert dboard:rundat into a composition of lists that pp will handle | | | | | | | | | | 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 | status start-time duration ) ;; register dboard:rundat with BBpp ;; this is used by BBpp (Brandon's pretty printer) to convert dboard:rundat into a composition of lists that pp will handle ;; (hash-table-set! *BBpp_custom_expanders_list* RUNDAT: ;; (cons dboard:rundat? ;; (lambda (tabdat-item) ;; (filter ;; (lambda (alist-entry) ;; (member (car alist-entry) ;; '(run run-data-offset ))) ;; FIELDS OF INTEREST ;; (dboard:rundat->alist tabdat-item))))) (define (dboard:rundat-make-init #!key (run #f)(key-vals #f)(tests #f));; -100 is before time began (make-dboard:rundat run: run |
︙ | ︙ | |||
582 583 584 585 586 587 588 589 590 591 592 593 594 595 | (if t-sort (cadr t-sort) 3))) (define (get-curr-sort) (vector-ref *tests-sort-options* *tests-sort-reverse*)) (debug:setup) ;; (define uidat #f) (define-inline (dboard:uidat-get-keycol vec)(vector-ref vec 0)) (define-inline (dboard:uidat-get-lftcol vec)(vector-ref vec 1)) (define-inline (dboard:uidat-get-header vec)(vector-ref vec 2)) | > > | 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 | (if t-sort (cadr t-sort) 3))) (define (get-curr-sort) (vector-ref *tests-sort-options* *tests-sort-reverse*)) ;;====================================================================== (debug:setup) ;; (define uidat #f) (define-inline (dboard:uidat-get-keycol vec)(vector-ref vec 0)) (define-inline (dboard:uidat-get-lftcol vec)(vector-ref vec 1)) (define-inline (dboard:uidat-get-header vec)(vector-ref vec 2)) |
︙ | ︙ | |||
649 650 651 652 653 654 655 | ;; ;; NOTE: Yes, this is used ;; (define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals) (let* ((start-time (current-seconds)) (access-mode (dboard:tabdat-access-mode tabdat)) (num-to-get (string->number (or (configf:lookup *configdat* "setup" "num-tests-to-get") | | | | 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 | ;; ;; NOTE: Yes, this is used ;; (define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals) (let* ((start-time (current-seconds)) (access-mode (dboard:tabdat-access-mode tabdat)) (num-to-get (string->number (or (configf:lookup *configdat* "setup" "num-tests-to-get") "1000"))) (states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))) (statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat))) (do-not-use-db-file-timestamps #f) ;; (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab (do-not-use-query-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-query-timestamps")) ;; this no longer troubles runs-summary-tab (sort-info (get-curr-sort)) (sort-by (vector-ref sort-info 1)) (sort-order (vector-ref sort-info 2)) (bubble-type (if (member sort-order '(testname)) 'testname 'itempath)) |
︙ | ︙ | |||
675 676 677 678 679 680 681 | ;;(dboard:tabdat-filters-changed tabdat)) 0 (dboard:rundat-last-update run-dat))) (last-db-time (if do-not-use-db-file-timestamps 0 (dboard:rundat-last-db-time run-dat))) (db-path (or (dboard:rundat-db-path run-dat) | | | | | | | | | | | | | | 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 | ;;(dboard:tabdat-filters-changed tabdat)) 0 (dboard:rundat-last-update run-dat))) (last-db-time (if do-not-use-db-file-timestamps 0 (dboard:rundat-last-db-time run-dat))) (db-path (or (dboard:rundat-db-path run-dat) (let* ((db-dir (get-environment-variable "MT_RUN_AREA_HOME")) ;; (common:get-db-tmp-area)) (db-pth (conc db-dir "/.mtdb/*.db"))) (dboard:rundat-db-path-set! run-dat db-pth) ;; this is just a cache of the path db-pth))) (db-mod-time (common:lazy-sqlite-db-modification-time db-path)) (db-modified (>= db-mod-time last-db-time)) (multi-get (> (dboard:rundat-run-data-offset run-dat) 0)) ;; multi-get in progress (tmptests (if (or do-not-use-db-file-timestamps (dboard:tabdat-filters-changed tabdat) db-modified) (rmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses (dboard:rundat-run-data-offset run-dat) ;; query offset num-to-get (dboard:tabdat-hide-not-hide tabdat) ;; no-in sort-by ;; sort-by sort-order ;; sort-order 'shortlist ;; qrytype (was #f) last-update ;; last-update *dashboard-mode*) ;; use dashboard mode '())) (use-new (dboard:tabdat-hide-not-hide tabdat)) (tests-ht (if (dboard:tabdat-filters-changed tabdat) (let ((ht (make-hash-table))) (dboard:rundat-tests-set! run-dat ht) ht) (dboard:rundat-tests run-dat))) (got-all (< (length tmptests) num-to-get)) ;; got all for this round ) ;; (debug:print-info 0 *default-log-port* "got-all="got-all", (hash-table-size tests-ht)="(hash-table-size tests-ht)) ;; if we saw the db modified, reset it (the signal has already been used) (if (and got-all ;; (not multi-get) db-modified) (dboard:rundat-last-db-time-set! run-dat (- start-time 2))) ;; to limit the amount of data transferred each cycle use limit of num-to-get and offset ;; DO NOT bump time indexes last-update and last-db-time until all the first pass of the ;; data has been read ;; set last-update to 0 if still getting data incrementally ;; NO NEED, handled above ;; ;; (debug:print 0 *default-log-port* "got-all: " got-all " multi-get: " multi-get " num-to-get: " num-to-get " (length tmptests): " (length tmptests) " db-modified: " db-modified " db-mod-time: " db-mod-time " db-path: " db-path) (if got-all (begin (dboard:rundat-last-update-set! run-dat (- start-time 2)) (dboard:rundat-run-data-offset-set! run-dat 0)) (begin (dboard:rundat-run-data-offset-set! run-dat (+ num-to-get (dboard:rundat-run-data-offset run-dat))))) (for-each (lambda (tdat) (let ((test-id (db:test-get-id tdat)) (state (db:test-get-state tdat))) (dboard:rundat-data-changed-set! run-dat #t) (if (equal? state "DELETED") (hash-table-delete! tests-ht test-id) (hash-table-set! tests-ht test-id tdat)))) tmptests) tests-ht)) ;; tmptests - new tests data ;; prev-tests - old tests data ;; ;; (define (dashboard:merge-changed-tests tabdat tests tmptests) ;; use-new prev-tests) ;; (let* ((newdat (filter |
︙ | ︙ | |||
822 823 824 825 826 827 828 | (elapsed-time (- (current-seconds) start-time))) (if (null? all-test-ids) (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id) (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct)) (if (or (null? tal) (> elapsed-time 2)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update (begin | | > > > > > > | 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 | (elapsed-time (- (current-seconds) start-time))) (if (null? all-test-ids) (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id) (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct)) (if (or (null? tal) (> elapsed-time 2)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update (begin (if (> elapsed-time 2)(debug:print 0 *default-log-port* "WARNING: timed out in update-testdat " elapsed-time "s")) (dboard:tabdat-allruns-set! tabdat new-res) maxtests) (if (> (dboard:rundat-run-data-offset run-struct) 0) (loop run tal new-res newmaxtests) ;; not done getting data for this run (loop (car tal)(cdr tal) new-res newmaxtests))))))) (dboard:tabdat-filters-changed-set! tabdat #f) (dboard:update-tree tabdat runs-hash header tb))) (define *dashboard-last-run-id-update* (make-hash-table)) ;; id => seconds (define (dboard:clear-run-id-update-hash) (hash-table-clear! *dashboard-last-run-id-update*)) ;; this calls dboard:get-tests-for-run-duplicate for each run ;; ;; create a virtual table of all the tests ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; (define (dboard:update-rundat tabdat runnamepatt numruns testnamepatt keypatts) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) |
︙ | ︙ | |||
867 868 869 870 871 872 873 | (dboard:tabdat-allruns-set! tabdat '()) (dboard:tabdat-all-test-names-set! tabdat '()) (dboard:tabdat-item-test-names-set! tabdat '()) (hash-table-clear! (dboard:tabdat-allruns-by-id tabdat))) (let loop ((run (car runs)) (tal (cdr runs)) (res '()) | | > > > > > > | > > > | | | | | | | | | | | | | | | | | | | | | | | > | | > > > > > | | | | | | > | | < < < | | | > > | > > | | | | 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 | (dboard:tabdat-allruns-set! tabdat '()) (dboard:tabdat-all-test-names-set! tabdat '()) (dboard:tabdat-item-test-names-set! tabdat '()) (hash-table-clear! (dboard:tabdat-allruns-by-id tabdat))) (let loop ((run (car runs)) (tal (cdr runs)) (res '()) (maxtests 0) (cont-run #f)) (let* ((run-id (db:get-value-by-header run header "id")) (recently-done (< (- (current-seconds) (hash-table-ref/default *dashboard-last-run-id-update* run-id 0)) 1)) (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)) ;; (last-update (if run-struct (dboard:rundat-last-update run-struct) 0)) (key-vals (rmt:get-key-vals run-id)) (tests-ht (let* ((tht (if (and recently-done run-struct) (let ((rht (dboard:rundat-tests run-struct))) ;; (dboard:tabdat-allruns-by-id tabdat))) (or rht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))) (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)))) (assert (hash-table? tht) "FATAL: But here tht should be a hash-table") tht)) ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate ;; dboard:get-tests-for-run-duplicate - returns a hash table ;; (dboard:get-tests-dat tabdat run-id last-update)) (all-test-ids (hash-table-keys tests-ht)) (num-tests (length all-test-ids)) ;; (print "run-struct: " run-struct) ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat) ;; (tests (bubble-up tmptests priority: bubble-type)) ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals) ;; Not sure this is needed? (newmaxtests (max num-tests maxtests)) ;; (last-update (- (current-seconds) 10)) (run-struct (or run-struct (dboard:rundat-make-init run: run tests: tests-ht key-vals: key-vals))) (new-res (if (null? all-test-ids) res (delete-duplicates (cons run-struct res) (lambda (a b) (eq? (db:get-value-by-header (dboard:rundat-run a) header "id") (db:get-value-by-header (dboard:rundat-run b) header "id")))))) (elapsed-time (- (current-seconds) start-time))) (if (null? all-test-ids) (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id) (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct)) (if (or (null? tal) (> elapsed-time 2)) ;; stop loading data after 5 ;; seconds, on the next call ;; more data *should* be ;; loaded since ;; get-tests-for-run uses last ;; update (begin (when (> elapsed-time 2) (debug:print 2 *default-log-port* "NOTE: updates are taking a long time, " elapsed-time "s elapsed.") (let* ((old-val (iup:attribute *tim* "TIME")) (new-val (number->string (inexact->exact (floor (* 2 (string->number old-val))))))) (if (< (string->number new-val) 5000) (begin (debug:print 2 *default-log-port* "NOTE: increasing poll interval from "old-val" to "new-val) (iup:attribute-set! *tim* "TIME" new-val))))) (dboard:tabdat-allruns-set! tabdat new-res) maxtests) (if (> (dboard:rundat-run-data-offset run-struct) 0) (begin (thread-sleep! 0.2) ;; let the gui re-draw (loop run tal new-res newmaxtests #t)) ;; not done getting data for this run (begin (hash-table-set! *dashboard-last-run-id-update* run-id (current-seconds)) (loop (car tal)(cdr tal) new-res newmaxtests #f))))))) (dboard:tabdat-filters-changed-set! tabdat #f) (dboard:update-tree tabdat runs-hash header tb))) (define *collapsed* (make-hash-table)) (define (toggle-hide lnum uidat) ; fulltestname) (let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum)) (fulltestname (iup:attribute btn "TITLE")) (parts (string-split fulltestname "(")) |
︙ | ︙ | |||
1004 1005 1006 1007 1008 1009 1010 | (if (> (length parts) 1)(conc " " (car (string-split (cadr parts) ")"))) newval)))) (vector-set! keycol i newval) (iup:attribute-set! lbl "TITLE" munged-val))) (iup:attribute-set! lbl "FGCOLOR" (if (hash-table-ref/default *collapsed* newval #f) "0 112 112" "0 0 0")) (if (< i maxn) (loop (+ i 1))))))) | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > | | | | > > | 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 | (if (> (length parts) 1)(conc " " (car (string-split (cadr parts) ")"))) newval)))) (vector-set! keycol i newval) (iup:attribute-set! lbl "TITLE" munged-val))) (iup:attribute-set! lbl "FGCOLOR" (if (hash-table-ref/default *collapsed* newval #f) "0 112 112" "0 0 0")) (if (< i maxn) (loop (+ i 1))))))) (define (get-itemized-tests test-dats) (let ((tnames '())) (for-each (lambda (tdat) (let ((tname (vector-ref tdat 0)) ;; (db:test-get-testname tdat)) (ipath (vector-ref tdat 1))) ;; (db:test-get-item-path tdat))) (if (not (equal? ipath "")) (if (and (list? tnames) (string? tname) (not (member tname tnames))) (set! tnames (cons tname tnames)))))) test-dats) (reverse tnames))) ;; Bubble up the top tests to above the items, collect the items underneath ;; all while preserving the sort order from the SQL query as best as possible. ;; (define (bubble-up tabdat test-dats #!key (priority 'itempath)) (if (null? test-dats) test-dats (begin (let* ((tnames '()) ;; list of names used to reserve order (tests-ht (make-hash-table)) ;; hash of lists, used to build as we go (itemized (get-itemized-tests test-dats))) #;(for-each (lambda (testdat) (let* ((tname (vector-ref testdat 0)) ;; db:test-get-testname testdat)) (ipath (vector-ref testdat 1))) ;; db:test-get-item-path testdat))) ;; (seen (hash-table-ref/default tests-th tname #f))) (if (not (member tname tnames)) (if (or (and (eq? priority 'itempath) (not (equal? ipath ""))) (and (eq? priority 'testname) (equal? ipath "")) (not (member tname itemized))) (set! tnames (append tnames (list tname))))) (if (equal? ipath "") ;; This a top level, prepend it (hash-table-set! tests-ht tname (cons testdat (hash-table-ref/default tests-ht tname '()))) ;; This is item, append it (hash-table-set! tests-ht tname (append (hash-table-ref/default tests-ht tname '())(list testdat)))))) test-dats) ;; 1. put all test/items into lists in tests-ht (for-each (lambda (testdat) (let* ((tname (vector-ref testdat 0)) ;; db:test-get-testname testdat)) (ipath (vector-ref testdat 1))) ;; db:test-get-item-path testdat))) ;; (seen (hash-table-ref/default tests-ht tname #f))) (if (not (member tname tnames)) (if (or (and (eq? priority 'itempath) (not (equal? ipath ""))) (and (eq? priority 'testname) (equal? ipath "")) (not (member tname itemized))) (set! tnames (append tnames (list tname))))) (hash-table-set! tests-ht tname (cons testdat (hash-table-ref/default tests-ht tname '()))))) test-dats) ;; now bubble up the non-item test in itemized tests (hash-table-for-each tests-ht (lambda (k v) (if (> (length v) 1) ;; must be itemized, push the no-item to the front (hash-table-set! tests-ht k (sort v (lambda (a b)(not (equal? (vector-ref b 1) "")))))))) ;; Set all tests with items (dboard:tabdat-item-test-names-set! tabdat (append (if (null? tnames) '() (filter (lambda (tname) (let ((tlst (hash-table-ref tests-ht tname))) (and (list tlst) (> (length tlst) 1)))) tnames)) (dboard:tabdat-item-test-names tabdat))) (let loop ((hed (car tnames)) (tal (cdr tnames)) (res '())) (let ((newres (append res (hash-table-ref tests-ht hed)))) (if (null? tal) newres (loop (car tal)(cdr tal) newres)))))))) ;; optimized to get runs constrained by what is visible on the screen ;; - not appropriate for where all the runs are needed ;; (define (update-buttons tabdat uidat numruns numtests) (let* ((runs (if (> (length (dboard:tabdat-allruns tabdat)) numruns) (take-right (dboard:tabdat-allruns tabdat) numruns) (pad-list (dboard:tabdat-allruns tabdat) numruns))) (lftcol (dboard:uidat-get-lftcol uidat)) (tableheader (dboard:uidat-get-header uidat)) (table (dboard:uidat-get-runsvec uidat)) (coln 0) (all-test-names (make-hash-table)) (use-bgcolor (equal? (configf:lookup *configdat* "dashboard" "use-bgcolor") "yes")) ;; doesn't work ) ;; create a concise list of test names ;; (for-each (lambda (rundat) (if rundat (let* ((testdats (dboard:rundat-tests rundat)) (testnames (map test:test-get-fullname (hash-table-values testdats)))) |
︙ | ︙ | |||
1110 1111 1112 1113 1114 1115 1116 | tabdat (let ((xl (if (> (length (dboard:tabdat-all-test-names tabdat)) (dboard:tabdat-start-test-offset tabdat)) (drop (dboard:tabdat-all-test-names tabdat) (dboard:tabdat-start-test-offset tabdat)) '()))) (append xl (make-list (- (dboard:tabdat-num-tests tabdat) (length xl)) "")))) (update-labels uidat (dboard:tabdat-all-test-names tabdat)) | | < > | | < | < < < < < > | | > | | | 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 | tabdat (let ((xl (if (> (length (dboard:tabdat-all-test-names tabdat)) (dboard:tabdat-start-test-offset tabdat)) (drop (dboard:tabdat-all-test-names tabdat) (dboard:tabdat-start-test-offset tabdat)) '()))) (append xl (make-list (- (dboard:tabdat-num-tests tabdat) (length xl)) "")))) (update-labels uidat (dboard:tabdat-all-test-names tabdat)) (for-each ;;run (lambda (rundat) (if (or (not rundat) ;; handle padded runs (not (dboard:rundat-run rundat))) ;; Need to put an empty column in to erase previous contents. (set! rundat (dboard:rundat-make-init key-vals: (map (lambda (x) "")(dboard:tabdat-keys tabdat))))) (let* ((run (dboard:rundat-run rundat)) (testsdat-by-name (dboard:rundat-tests-by-name rundat)) (key-val-dat (dboard:rundat-key-vals rundat)) (run-id (db:get-value-by-header run (dboard:tabdat-header tabdat) "id")) (key-vals (append key-val-dat (list (let ((x (db:get-value-by-header run (dboard:tabdat-header tabdat) "runname"))) (if (string? x) x ""))))) (run-key (string-intersperse key-vals "\n"))) ;; fill in the run header key values ;; (let ((rown 0) (headercol (vector-ref tableheader coln))) (for-each (lambda (kval) (let* ((labl (vector-ref headercol rown))) (if (not (equal? kval (iup:attribute labl "TITLE"))) (iup:attribute-set! (vector-ref headercol rown) "TITLE" kval)) (set! rown (+ rown 1)))) key-vals)) ;; For this run now fill in the buttons for each test ;; (let ((rown 0) (columndat (vector-ref table coln))) (for-each (lambda (testname) (let ((buttondat (hash-table-ref/default (dboard:tabdat-buttondat tabdat) (mkstr coln rown) #f))) (if (and buttondat (hash-table? testsdat-by-name)) (let* ((testdat (let ((matching (hash-table-ref/default testsdat-by-name testname #f))) ;; (filter ;; (lambda (x)(equal? (test:test-get-fullname x) testname)) ;; testsdat))) (if (not matching) (vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "") ;; (car matching)))) matching))) (teststatus (db:test-get-status testdat)) (teststate (db:test-get-state testdat)) (buttontxt (cond ((member teststate '("COMPLETED" "ARCHIVED")) teststatus) ((and (equal? teststate "NOT_STARTED") (member teststatus '("ZERO_ITEMS" "BLOCKED" "PREQ_FAIL" "PREQ_DISCARDED" "TIMED_OUT" "KEEP_TRYING" "TEN_STRIKES"))) teststatus) (else teststate))) (button (vector-ref columndat rown)) (color (car (gutils:get-color-for-state-status teststate teststatus))) (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR")) (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE"))) (if (not (equal? curr-color color)) (if use-bgcolor (iup:attribute-set! button "BGCOLOR" color) (iup:attribute-set! button "IMAGE" (make-image *images* buttontxt color)))) (if (and (not use-bgcolor) ;; bgcolor does not work with text (not (equal? curr-title buttontxt))) (iup:attribute-set! button "TITLE" buttontxt)) (vector-set! buttondat 0 run-id) (vector-set! buttondat 1 color) (vector-set! buttondat 2 buttontxt) (vector-set! buttondat 3 testdat) (vector-set! buttondat 4 run-key))) (set! rown (+ rown 1)))) (dboard:tabdat-all-test-names tabdat))) |
︙ | ︙ | |||
1357 1358 1359 1360 1361 1362 1363 | (equal? tp "")) "%" tp))) (states (dboard:tabdat-states tabdat)) (statuses (dboard:tabdat-statuses tabdat)) (target (let ((targ-list (dboard:tabdat-target tabdat))) (if targ-list (string-intersperse targ-list "/") "no-target-selected"))) | | > > > > | 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 | (equal? tp "")) "%" tp))) (states (dboard:tabdat-states tabdat)) (statuses (dboard:tabdat-statuses tabdat)) (target (let ((targ-list (dboard:tabdat-target tabdat))) (if targ-list (string-intersperse targ-list "/") "no-target-selected"))) (run-name (let ((run-input (dboard:tabdat-run-name tabdat)) ) (if (equal? run-input "") "no-runname-specified" run-input))) (states-str (if (or (not states) (null? states)) "" (conc " -state " (string-intersperse states ",")))) (statuses-str (if (or (not statuses) (null? statuses)) "" |
︙ | ︙ | |||
1524 1525 1526 1527 1528 1529 1530 | ;;(iup:frame ;; #:title "Logs" ;; To be replaced with tabs ;; (let ((logs-tb (iup:textbox #:expand "YES" ;; #:multiline "YES"))) ;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb) ;; logs-tb)) | < < < < > > > > | > > | | 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 | ;;(iup:frame ;; #:title "Logs" ;; To be replaced with tabs ;; (let ((logs-tb (iup:textbox #:expand "YES" ;; #:multiline "YES"))) ;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb) ;; logs-tb)) ;; browse runs as a tree. Used in both "Runs" tab and ;; in the runs control panel. ;; (define (dboard:runs-tree-browser commondat tabdat) (let* ((txtbox (iup:textbox #:action (lambda (val a b) (debug:catch-and-dump (lambda () ;; for the Runs view we put the list ;; of keyvals into tabdat target for ;; the Run Controls we put then update ;; the run-command (if b (dboard:tabdat-target-set! tabdat (string-split b "/"))) (dashboard:update-run-command tabdat)) "command-testname-selector tb action")) #:value (dboard:test-patt->lines (dboard:tabdat-test-patts-use tabdat)) #:expand "HORIZONTAL" ;; #:size "10x30" )) (tb (iup:treebox #:value 0 #:title "Runs" ;; was #:name -- iup 3.19 changed |
︙ | ︙ | |||
1584 1585 1586 1587 1588 1589 1590 | (dboard:tabdat-curr-run-id-set! tabdat run-id) (dboard:tabdat-view-changed-set! tabdat #t)) (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id)))) "treebox")) ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) ))) (dboard:tabdat-runs-tree-set! tabdat tb) | < < < < < < < < | 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 | (dboard:tabdat-curr-run-id-set! tabdat run-id) (dboard:tabdat-view-changed-set! tabdat #t)) (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id)))) "treebox")) ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) ))) (dboard:tabdat-runs-tree-set! tabdat tb) (iup:detachbox (iup:vbox txtbox tb )))) ;; browse runs as a tree. Used in both "Runs" tab and |
︙ | ︙ | |||
1632 1633 1634 1635 1636 1637 1638 | ;; this... "Changed:Â [DEPRECATED ;; REMOVED] removed the old attribute ;; NAMEid from IupTree to avoid ;; conflict with the common attribute ;; NAME. Use the TITLEid attribute." #:expand "YES" #:addexpanded "YES" | | | 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 | ;; this... "Changed:Â [DEPRECATED ;; REMOVED] removed the old attribute ;; NAMEid from IupTree to avoid ;; conflict with the common attribute ;; NAME. Use the TITLEid attribute." #:expand "YES" #:addexpanded "YES" ;; #:size "10x" #:selection-cb (lambda (obj id state) (debug:catch-and-dump (lambda () (let* ((run-path (tree:node->path obj id)) (run-id (new-tree-path->run-id rdat (cdr run-path)))) ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ?? |
︙ | ︙ | |||
1718 1719 1720 1721 1722 1723 1724 | "Compact layout" #:fontsize 8 #:expand "HORIZONTAL" #:value 1 #:action (lambda (obj tstate) (debug:catch-and-dump (lambda () | | | 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 | "Compact layout" #:fontsize 8 #:expand "HORIZONTAL" #:value 1 #:action (lambda (obj tstate) (debug:catch-and-dump (lambda () ;; (print "tstate: " tstate) (if (eq? tstate 0) (dboard:tabdat-compact-layout-set! tabdat #f) (dboard:tabdat-compact-layout-set! tabdat #t)) (dboard:tabdat-last-filter-str-set! tabdat "") ) "text-list-toggle-box")))) (dcommon:command-runname-selector commondat tabdat tab-num: tab-num) |
︙ | ︙ | |||
1911 1912 1913 1914 1915 1916 1917 | ;; userdata: (conc "run-id: " run-id)))) (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id) ;; (set! colnum (+ colnum 1)) )))) run-ids))) (define (dashboard:tests-ht->tests-dat tests-ht) | < < < < < < < < < < < | | | | | | | | | | | | < < < < | | | | | | 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 | ;; userdata: (conc "run-id: " run-id)))) (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id) ;; (set! colnum (+ colnum 1)) )))) run-ids))) (define (dashboard:tests-ht->tests-dat tests-ht) (reverse (sort (hash-table-values tests-ht) (lambda (a b) (let ((a-test-name (db:test-get-testname a)) (a-item-path (db:test-get-item-path a)) (b-test-name (db:test-get-testname b)) (b-item-path (db:test-get-item-path b)) (a-event-time (db:test-get-event_time a)) (b-event-time (db:test-get-event_time b))) (if (not (equal? a-test-name b-test-name)) (> a-event-time b-event-time) (cond ((< 0 (string-compare3 a-test-name b-test-name)) #t) ((> 0 (string-compare3 a-test-name b-test-name)) #f) ((< 0 (string-compare3 a-item-path b-item-path)) #t) (else #f)))))))) (define (dashboard:run-id->tests-mindat run-id tabdat runs-hash) (let* ((run (hash-table-ref/default runs-hash run-id #f)) (key-vals (rmt:get-key-vals run-id)) (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%")) (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) |
︙ | ︙ | |||
1972 1973 1974 1975 1976 1977 1978 | (dcommon:xor-tests-mindat (dashboard:run-id->tests-mindat src-run-id tabdat runs-hash) (dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash) hide-clean: hide-clean) #f))) | | | 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 | (dcommon:xor-tests-mindat (dashboard:run-id->tests-mindat src-run-id tabdat runs-hash) (dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash) hide-clean: hide-clean) #f))) (define (dashboard:get-runs-hash tabdat) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) (last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat)) (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (runs (vector-ref runs-dat 1)) (run-id (dboard:tabdat-curr-run-id tabdat)) (runs-hash (let ((ht (make-hash-table))) |
︙ | ︙ | |||
2041 2042 2043 2044 2045 2046 2047 | (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL"))) (iup:attribute-set! run-matrix "NUMCOL" max-col )) (let ((effective-max-row (if (< max-row max-visible) max-visible max-row))) (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN"))) (iup:attribute-set! run-matrix "NUMLIN" effective-max-row ))) | < < | 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 | (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL"))) (iup:attribute-set! run-matrix "NUMCOL" max-col )) (let ((effective-max-row (if (< max-row max-visible) max-visible max-row))) (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN"))) (iup:attribute-set! run-matrix "NUMLIN" effective-max-row ))) ;; Row labels (for-each (lambda (ind) (let* ((name (car ind)) (num (cadr ind)) (key (conc num ":0"))) (if (not (equal? (iup:attribute run-matrix key) name)) |
︙ | ︙ | |||
2082 2083 2084 2085 2086 2087 2088 | (begin (set! changed #t) (iup:attribute-set! run-matrix key (cadr value)) (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) matrix-content) ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. | | | | | 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 | (begin (set! changed #t) (iup:attribute-set! run-matrix key (cadr value)) (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) matrix-content) ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. (for-each (lambda (ind) (let* ((name (car ind)) (num (cadr ind)) (key (conc "0:" num))) (if (not (equal? (iup:attribute run-matrix key) name)) (begin (set! changed #t) (iup:attribute-set! run-matrix key name) (if (<= num max-col) (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num))))))) col-indices) (if (and (eq? pass-num 0) changed) (loop 1 #t)) ;; force second pass due to column labels changing ;; (debug:print 0 *default-log-port* "runs-summary-updater, changed: " changed " pass-num: " pass-num) |
︙ | ︙ | |||
2172 2173 2174 2175 2176 2177 2178 | (begin (print-call-chain) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) (debug:print 0 *default-log-port* "ERROR: failed call procedure " viewgen ", with; tab-num=" tab-num ", view-name=" view-name ", and views-cfgdat and megatest configdat as parameters. To debug try loading in the repl: megatest -repl") (set! success #f)) | | | 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 | (begin (print-call-chain) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) (debug:print 0 *default-log-port* "ERROR: failed call procedure " viewgen ", with; tab-num=" tab-num ", view-name=" view-name ", and views-cfgdat and megatest configdat as parameters. To debug try loading in the repl: megatest -repl") (set! success #f)) (debug:print 0 *default-log-port* "Adding tab " view-name " with proc " viewgen) ;; (iup:child-add! tabs (set! result-child ((eval (string->symbol viewgen)) commondat tabs tab-num view-name views-cfgdat *configdat*)))) ;; and finally set the updater (if success (dboard:commondat-add-updater commondat (lambda () |
︙ | ︙ | |||
2294 2295 2296 2297 2298 2299 2300 | ;; This is the Run Summary tab ;; (define (dashboard:runs-summary commondat tabdat #!key (tab-num #f)) (let* ((update-mutex (dboard:commondat-update-mutex commondat)) (tb (iup:treebox #:value 0 ;;#:name "Runs" | | | 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 | ;; This is the Run Summary tab ;; (define (dashboard:runs-summary commondat tabdat #!key (tab-num #f)) (let* ((update-mutex (dboard:commondat-update-mutex commondat)) (tb (iup:treebox #:value 0 ;;#:name "Runs" #:title "Runs" #:expand "YES" #:addexpanded "YES" #:selection-cb (lambda (obj id state) (debug:catch-and-dump (lambda () ;; (print "obj: " obj ", id: " id ", state: " state) |
︙ | ︙ | |||
2382 2383 2384 2385 2386 2387 2388 | #:modal? "NO") ) ) )) "runs-summary-click-callback")))) (runs-summary-updater (lambda () | | | > | 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 | #:modal? "NO") ) ) )) "runs-summary-click-callback")))) (runs-summary-updater (lambda () ;; (mutex-lock! update-mutex) (if (or (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-updater) (dboard:tabdat-view-changed tabdat)) (debug:catch-and-dump (lambda () ;; check that run-matrix is initialized before calling the updater (if run-matrix (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix))) "dashboard:runs-summary-updater") ) #;(mutex-unlock! update-mutex) )) (runs-summary-control-panel (dashboard:runs-summary-control-panel tabdat)) ) (dboard:commondat-add-updater commondat runs-summary-updater tab-num: tab-num) (dboard:tabdat-runs-tree-set! tabdat tb) (iup:vbox (iup:split #:value 200 |
︙ | ︙ | |||
2438 2439 2440 2441 2442 2443 2444 | (iup:vbox (iup:hbox (iup:vbox (iup:textbox #:size "120x15" #:fontsize "10" #:value "%" #:expand "NO" #:action (lambda (obj unk val) (debug:catch-and-dump | | > | 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 | (iup:vbox (iup:hbox (iup:vbox (iup:textbox #:size "120x15" #:fontsize "10" #:value "%" #:expand "NO" #:action (lambda (obj unk val) (debug:catch-and-dump (lambda ()57 (mark-for-update tabdat) (update-search commondat tabdat "test-name" val)) "make-controls"))) (iup:hbox (iup:button "Quit" #:action (lambda (obj) (exit)) #:expand "NO" #:size "40x15") (iup:button "Refresh" #:action (lambda (obj) (dboard:tabdat-last-data-update-set! tabdat 0) (dboard:tabdat-last-runs-update-set! tabdat 0) (dboard:tabdat-run-update-times-set! tabdat (make-hash-table)) (dboard:tabdat-last-test-dat-set! tabdat (make-hash-table)) (dboard:tabdat-allruns-set! tabdat '()) (dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table)) (dboard:tabdat-done-runs-set! tabdat '()) (dboard:tabdat-not-done-runs-set! tabdat '()) (dboard:tabdat-view-changed-set! tabdat #t) (dboard:commondat-please-update-set! commondat #t) (dboard:clear-run-id-update-hash) (mark-for-update tabdat)) #:expand "NO" #:size "40x15") (iup:button "Collapse" #:action (lambda (obj) (debug:catch-and-dump (lambda () (let ((myname (iup:attribute obj "TITLE"))) (if (equal? myname "Collapse") |
︙ | ︙ | |||
2511 2512 2513 2514 2515 2516 2517 | ;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-empty-runs tabdat) "+HideE" "-HideE")) ;; (mark-for-update tabdat)))) (set! hide (iup:button "Hide" #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL" #:action (lambda (obj) (dboard:tabdat-hide-not-hide-set! tabdat #t) ;; (not (dboard:tabdat-hide-not-hide tabdat))) ;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-not-hide tabdat) "HideTests" "NotHide")) | | | | | | | | 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 | ;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-empty-runs tabdat) "+HideE" "-HideE")) ;; (mark-for-update tabdat)))) (set! hide (iup:button "Hide" #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL" #:action (lambda (obj) (dboard:tabdat-hide-not-hide-set! tabdat #t) ;; (not (dboard:tabdat-hide-not-hide tabdat))) ;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-not-hide tabdat) "HideTests" "NotHide")) (iup:attribute-set! hide "BGCOLOR" sel-color) (iup:attribute-set! show "BGCOLOR" nonsel-color) (mark-for-update tabdat)))) (set! show (iup:button "Show" #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL" #:action (lambda (obj) (dboard:tabdat-hide-not-hide-set! tabdat #f) ;; (not (dboard:tabdat-hide-not-hide tabdat))) (iup:attribute-set! show "BGCOLOR" sel-color) (iup:attribute-set! hide "BGCOLOR" nonsel-color) (mark-for-update tabdat)))) (iup:attribute-set! hide "BGCOLOR" sel-color) (iup:attribute-set! show "BGCOLOR" nonsel-color) ;; (dboard:tabdat-hide-not-hide-button-set! tabdat hideit) ;; never used, can eliminate ... (iup:vbox (iup:hbox hide show) sort-lb))) ) ;; insert extra widget here |
︙ | ︙ | |||
2761 2762 2763 2764 2765 2766 2767 | #:orientation "VERTICAL" ;; "HORIZONTAL" #:value 100 (dboard:runs-tree-new-browser commondat rdat) (dboard:runs-new-matrix commondat rdat) ))) (define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat) | > | | 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 | #:orientation "VERTICAL" ;; "HORIZONTAL" #:value 100 (dboard:runs-tree-new-browser commondat rdat) (dboard:runs-new-matrix commondat rdat) ))) (define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat) (let* ( (stats-dat (dboard:tabdat-make-data)) (runs-dat (dboard:tabdat-make-data)) (runs2-dat (make-dboard:rdat)) ;; (dboard:tabdat-make-data)) (onerun-dat (dboard:tabdat-make-data)) ;; name for run-summary structure (runcontrols-dat (dboard:tabdat-make-data)) (runtimes-dat (dboard:tabdat-make-data)) (nruns (dboard:tabdat-numruns runs-dat)) (ntests (dboard:tabdat-num-tests runs-dat)) |
︙ | ︙ | |||
2783 2784 2785 2786 2787 2788 2789 | (lftlst '()) (hdrlst '()) (bdylst '()) (result '()) (i 0) (btn-height (dboard:tabdat-runs-btn-height runs-dat)) (btn-fontsz (dboard:tabdat-runs-btn-fontsz runs-dat)) | | > | | < < < | < | 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 | (lftlst '()) (hdrlst '()) (bdylst '()) (result '()) (i 0) (btn-height (dboard:tabdat-runs-btn-height runs-dat)) (btn-fontsz (dboard:tabdat-runs-btn-fontsz runs-dat)) (cell-width (dboard:tabdat-runs-cell-width runs-dat)) (use-bgcolor (equal? (configf:lookup *configdat* "dashboard" "use-bgcolor") "yes"))) ;; controls (along bottom) ;; (set! controls (dboard:make-controls commondat runs-dat)) ;; create the left most column for the run key names and the test names (set! lftlst (list (iup:hbox (iup:label) ;; (iup:valuator) (apply iup:vbox (map (lambda (x) (let ((res (iup:hbox #:expand "HORIZONTAL" (iup:label x #:size (conc 40 btn-height) #:fontsize btn-fontsz #:expand "NO") ;; "HORIZONTAL") (iup:textbox #:size (conc 35 btn-height) #:fontsize btn-fontsz #:value "%" #:expand "NO" ;; "HORIZONTAL" #:action (lambda (obj unk val) ;; each field ;; (field name is "x" var) live updates ;; the search filter as it is typed (dboard:tabdat-target-set! runs-dat #f) ;; ensure fields text boxes are used |
︙ | ︙ | |||
2898 2899 2900 2901 2902 2903 2904 | ((>= testnum ntests) (vector-set! runsvec runnum testvec) (set! bdylst (cons (apply iup:vbox (reverse res)) bdylst)) (loop (+ runnum 1) 0 (make-vector ntests) '())) (else (let* ((button-key (mkstr runnum testnum)) (butn (iup:button | | < | 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 | ((>= testnum ntests) (vector-set! runsvec runnum testvec) (set! bdylst (cons (apply iup:vbox (reverse res)) bdylst)) (loop (+ runnum 1) 0 (make-vector ntests) '())) (else (let* ((button-key (mkstr runnum testnum)) (butn (iup:button (if use-bgcolor #f " ") ;; button-key #:size (conc cell-width btn-height ) #:expand "HORIZONTAL" #:fontsize btn-fontsz #:button-cb (lambda (obj a pressed x y btn . rem) ;; (print "pressed= " pressed " x= " x " y= " y " rem=" rem " btn=" btn " string? " (string? btn)) (if (substring-index "3" btn) (if (eq? pressed 1) (let* ((toolpath (car (argv))) |
︙ | ︙ | |||
2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 | )) (if (eq? pressed 0) (let* ((toolpath (car (argv))) (buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key)) (test-id (db:test-get-id (vector-ref buttndat 3))) (run-id (db:test-get-run_id (vector-ref buttndat 3)))) (dboard:launch-testpanel run-id test-id)))))))) (hash-table-set! (dboard:tabdat-buttondat runs-dat) button-key (vector 0 "100 100 100" button-key #f #f)) (vector-set! testvec testnum butn) (loop runnum (+ testnum 1) testvec (cons butn res)))))) ;; now assemble the hdrlst and bdylst and kick off the dialog (iup:show (iup:dialog #:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*) #:menu (dcommon:main-menu) (let* ((runs-view (iup:vbox (iup:split #:orientation "VERTICAL" ;; "HORIZONTAL" | > | | | 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 | )) (if (eq? pressed 0) (let* ((toolpath (car (argv))) (buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key)) (test-id (db:test-get-id (vector-ref buttndat 3))) (run-id (db:test-get-run_id (vector-ref buttndat 3)))) (dboard:launch-testpanel run-id test-id)))))))) (iup:attribute-set! butn "IMAGE" (make-image *images* "BGCOLOR" "222 222 221")) ;;; "BGCOLOR" "BGCOLOR") (hash-table-set! (dboard:tabdat-buttondat runs-dat) button-key (vector 0 "100 100 100" button-key #f #f)) (vector-set! testvec testnum butn) (loop runnum (+ testnum 1) testvec (cons butn res)))))) ;; now assemble the hdrlst and bdylst and kick off the dialog (iup:show (iup:dialog #:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*) #:menu (dcommon:main-menu) (let* ((runs-view (iup:vbox (iup:split #:orientation "VERTICAL" ;; "HORIZONTAL" #:value 250 (dboard:runs-tree-browser commondat runs-dat) (iup:split #:value 200 ;; left most block, including row names (apply iup:vbox lftlst) ;; right hand block, including cells (iup:vbox #:expand "YES" ;; the header (apply iup:hbox (reverse hdrlst)) |
︙ | ︙ | |||
3010 3011 3012 3013 3014 3015 3016 | (dboard:tabdat-layout-update-ok-set! tabdat #f)) (dboard:commondat-curr-tab-num-set! commondat curr) (let* ((tab-num (dboard:commondat-curr-tab-num commondat)) (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) (dboard:commondat-please-update-set! commondat #t) (dboard:tabdat-layout-update-ok-set! tabdat #t))) "tabchangepos")) | < > | > > | | | > > > > > > | | 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 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 | (dboard:tabdat-layout-update-ok-set! tabdat #f)) (dboard:commondat-curr-tab-num-set! commondat curr) (let* ((tab-num (dboard:commondat-curr-tab-num commondat)) (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) (dboard:commondat-please-update-set! commondat #t) (dboard:tabdat-layout-update-ok-set! tabdat #t))) "tabchangepos")) runs-view (dashboard:summary commondat stats-dat tab-num: 1) ;; (make-runs-view commondat runs2-dat 2) (dashboard:runs-summary commondat onerun-dat tab-num: 2) (dashboard:run-controls commondat runcontrols-dat tab-num: 3) (dashboard:run-times commondat runtimes-dat tab-num: 4) additional-views)) (target-run (dboard:commondat-target commondat)) ) ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) (iup:attribute-set! tabs "TABTITLE0" "Runs") (iup:attribute-set! tabs "TABTITLE1" "Summary") ;; (iup:attribute-set! tabs "TABTITLE2" "Runs2") (iup:attribute-set! tabs "TABTITLE2" "Run Summary") (iup:attribute-set! tabs "TABTITLE3" "Run Control") (iup:attribute-set! tabs "TABTITLE4" "Run Times") ;; (iup:attribute-set! tabs "TABTITLE3" "New View") ;; (iup:attribute-set! tabs "TABTITLE4" "Run Control") ;; set the tab names for user added tabs (for-each (lambda (tab-info) (iup:attribute-set! tabs (conc "TABTITLE" (car tab-info)) (cdr tab-info))) additional-tabnames) (iup:attribute-set! tabs "BGCOLOR" "190 190 190") ;; make the iup tabs object available (for changing color for example) (dboard:commondat-hide-not-hide-tabs-set! commondat tabs) ;; now set up the tabdat lookup ;; (dboard:common-set-tabdat! commondat 0 stats-dat) (if target-run (begin (dboard:tabdat-target-set! runs-dat (string-split target-run "/")) ) ) (dboard:common-set-tabdat! commondat 0 runs-dat) ;;(dboard:common-set-tabdat! commondat 2 runs2-dat) (dboard:common-set-tabdat! commondat 2 onerun-dat) (dboard:common-set-tabdat! commondat 3 runcontrols-dat) (dboard:common-set-tabdat! commondat 4 runtimes-dat) (iup:vbox tabs |
︙ | ︙ | |||
3084 3085 3086 3087 3088 3089 3090 | exn (begin (debug:print 2 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn) " db-dir="dbdir ", exn=" exn) (current-seconds)) ;; something went wrong - just print an error and return current-seconds (common:max (map (lambda (filen) (file-modification-time filen)) | | | 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 | exn (begin (debug:print 2 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn) " db-dir="dbdir ", exn=" exn) (current-seconds)) ;; something went wrong - just print an error and return current-seconds (common:max (map (lambda (filen) (file-modification-time filen)) (cons (conc dbdir "/main.db") (glob (conc dbdir "/?.db"))))))) (define (dashboard:monitor-changed? commondat tabdat) (let* ((run-update-time (current-seconds)) (monitor-db-path (dboard:tabdat-monitor-db-path tabdat)) (monitor-modtime (if (and monitor-db-path (common:file-exists? monitor-db-path)) (file-modification-time monitor-db-path) -1))) |
︙ | ︙ | |||
3106 3107 3108 3109 3110 3111 3112 | (define (dboard:get-last-db-update tabdat context) (hash-table-ref/default (dboard:tabdat-last-db-update tabdat) context 0)) (define (dboard:set-last-db-update! tabdat context newtime) (hash-table-set! (dboard:tabdat-last-db-update tabdat) context newtime)) | < < | < | 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 | (define (dboard:get-last-db-update tabdat context) (hash-table-ref/default (dboard:tabdat-last-db-update tabdat) context 0)) (define (dboard:set-last-db-update! tabdat context newtime) (hash-table-set! (dboard:tabdat-last-db-update tabdat) context newtime)) ;; (define (dashboard:database-changed? commondat tabdat #!key (context-key 'default)) (let* ((run-update-time (current-seconds)) (dbdir (conc *toppath* "/.mtdb")) (modtime (dashboard:get-youngest-run-db-mod-time dbdir)) (recalc (dashboard:recalc modtime (dboard:commondat-please-update commondat) (dboard:get-last-db-update tabdat context-key)))) (if recalc (dboard:set-last-db-update! tabdat context-key run-update-time)) (dboard:commondat-please-update-set! commondat #f) recalc)) ;; point inside line ;; |
︙ | ︙ | |||
3281 3282 3283 3284 3285 3286 3287 | "%")) (testpatt (or (dboard:tabdat-test-patts tabdat) "%")) (filtrstr (conc targpatt "/" runpatt "/" testpatt))) ;; (print "targpatt: " targpatt " runpatt: " runpatt " testpatt: " testpatt) (if (not (equal? (dboard:tabdat-last-filter-str tabdat) filtrstr)) (let ((dwg (dboard:tabdat-drawing tabdat))) | < | 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 | "%")) (testpatt (or (dboard:tabdat-test-patts tabdat) "%")) (filtrstr (conc targpatt "/" runpatt "/" testpatt))) ;; (print "targpatt: " targpatt " runpatt: " runpatt " testpatt: " testpatt) (if (not (equal? (dboard:tabdat-last-filter-str tabdat) filtrstr)) (let ((dwg (dboard:tabdat-drawing tabdat))) (dboard:tabdat-layout-update-ok-set! tabdat #f) (vg:drawing-libs-set! dwg (make-hash-table)) (vg:drawing-insts-set! dwg (make-hash-table)) (vg:drawing-cache-set! dwg '()) (dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table)) ;; (dboard:tabdat-allruns-set! tabdat '()) (dboard:tabdat-max-row-set! tabdat 0) |
︙ | ︙ | |||
3320 3321 3322 3323 3324 3325 3326 | (dwg (dboard:tabdat-drawing tabdat)) (mtx (dboard:tabdat-runs-mutex tabdat)) (vch (dboard:tabdat-view-changed tabdat))) (if (and cnv dwg vch) (begin (vg:drawing-xoff-set! dwg (dboard:tabdat-xadj tabdat)) (vg:drawing-yoff-set! dwg (dboard:tabdat-yadj tabdat)) | | | | | 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 | (dwg (dboard:tabdat-drawing tabdat)) (mtx (dboard:tabdat-runs-mutex tabdat)) (vch (dboard:tabdat-view-changed tabdat))) (if (and cnv dwg vch) (begin (vg:drawing-xoff-set! dwg (dboard:tabdat-xadj tabdat)) (vg:drawing-yoff-set! dwg (dboard:tabdat-yadj tabdat)) ;; (mutex-lock! mtx) (canvas-clear! cnv) (vg:draw dwg tabdat) ;; (mutex-unlock! mtx) (dboard:tabdat-view-changed-set! tabdat #f))))) ;; doesn't work. ;; ;;(define (gotoescape tabdat escape) ;; (or (dboard:tabdat-layout-update-ok tabdat) ;; (escape #t))) (define (dboard:graph-db-open dbstr) (let* ((parts (string-split dbstr ":")) (dbpth (if (< (length parts) 2) ;; assume then a filename was provided dbstr (if (equal? (car parts) "sqlite3") (cadr parts) (begin (debug:print 0 *default-log-port* "ERROR: I only know sqlite3 databases for now: " dbstr) #f))))) (if (and dbpth (file-read-access? dbpth)) (let ((db (sqlite3:open-database dbpth))) ;; (open-database dbpth))) (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 10000)) db) #f))) ;; sqlite3:path tablename timefieldname varfieldname field1 field2 ... ;; (define (dboard:graph-read-data cmdstring tstart tend) (let* ((parts (string-split cmdstring))) ;; spaces not allowed |
︙ | ︙ | |||
3511 3512 3513 3514 3515 3516 3517 | (vg:make-line-obj last-tval last-yval curr-tval last-yval line-color: graph-color)) (vg:add-obj-to-comp cmp ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale)) (vg:make-line-obj curr-tval last-yval curr-tval next-yval line-color: graph-color))) | | | 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 | (vg:make-line-obj last-tval last-yval curr-tval last-yval line-color: graph-color)) (vg:add-obj-to-comp cmp ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale)) (vg:make-line-obj curr-tval last-yval curr-tval next-yval line-color: graph-color))) (debug:print 0 *default-log-port* "ERROR: curr-tval is not > last-tval; curr-tval " curr-tval ", last-tval " last-tval)))) next) #f ;; (vector tstart minval minval) dat) )))))) ;; for each data point in the series (hash-table-keys alldat))))) cfg) (if changed (iup:attribute-set! graph-matrix "REDRAW" "ALL")))) |
︙ | ︙ | |||
3607 3608 3609 3610 3611 3612 3613 | (width (* timescale run-duration)) (graph-lly (calc-y (/ -50 row-height))) (graph-uly (- (calc-y 0) canvas-margin)) (sec-per-50pt (/ 50 timescale)) ) ;; (print "timeoffset: " timeoffset " timescale: " timescale " run-duration: " (seconds->hr-min-sec run-duration) " width: " width " sec-per-50pt: " sec-per-50pt) ;; (print "timescale: " timescale " timeoffset: " timeoffset " sizex: " sizex " originx: " originx) | | | | 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 | (width (* timescale run-duration)) (graph-lly (calc-y (/ -50 row-height))) (graph-uly (- (calc-y 0) canvas-margin)) (sec-per-50pt (/ 50 timescale)) ) ;; (print "timeoffset: " timeoffset " timescale: " timescale " run-duration: " (seconds->hr-min-sec run-duration) " width: " width " sec-per-50pt: " sec-per-50pt) ;; (print "timescale: " timescale " timeoffset: " timeoffset " sizex: " sizex " originx: " originx) ;; (mutex-lock! mtx) (vg:add-comp-to-lib runslib run-full-name runcomp) ;; Have to keep moving the instantiated box as it is anchored at the lower left ;; this should have worked for x in next statement? (maptime run-start) ;; add 60 to make room for the graph (vg:instantiate drawing "runslib" run-full-name run-full-name 8 (- (calc-y curr-run-start-row) (+ 5 graph-height run-to-run-margin))) ;; (mutex-unlock! mtx) ;; (set! run-start-row (+ max-row 2)) ;; (dboard:tabdat-start-row-set! tabdat (+ new-run-start-row 1)) ;; get tests in list sorted by event time ascending (let testsloop ((test-ids (car hierdat)) ;; loop on tests (NOTE: not items!) (tests-tal (cdr hierdat)) (test-num 1)) (let ((iterated (> (length test-ids) 1)) |
︙ | ︙ | |||
3672 3673 3674 3675 3676 3677 3678 | ;; (vg:instance-move drawing run-full-name 0 (calc-y (dboard:tabdat-max-row tabdat))) (dboard:tabdat-view-changed-set! tabdat #t) (cons obj test-objs)))))) ;; (print "event_time: " (db:test-get-event_time testdat) " mapped event_time: " event-time) ;; (print "run-duration: " (db:test-get-run_duration testdat) " mapped run_duration: " run-duration) (if (> item-num 50) (if (eq? 0 (modulo item-num 50)) | | | 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 | ;; (vg:instance-move drawing run-full-name 0 (calc-y (dboard:tabdat-max-row tabdat))) (dboard:tabdat-view-changed-set! tabdat #t) (cons obj test-objs)))))) ;; (print "event_time: " (db:test-get-event_time testdat) " mapped event_time: " event-time) ;; (print "run-duration: " (db:test-get-run_duration testdat) " mapped run_duration: " run-duration) (if (> item-num 50) (if (eq? 0 (modulo item-num 50)) (debug:print 0 *default-log-port* "processing " run-num " of " num-runs " runs " item-num " of " num-items " of test " test-name ", " test-num " of " num-tests " tests"))) ;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration) (let ((newdoneruns (cons rundat doneruns))) (if (null? tidstal) (if iterated (let* ((xtents (vg:get-extents-for-objs drawing new-test-objs)) (llx (- (car xtents) 10)) (lly (- (cadr xtents) 10)) |
︙ | ︙ | |||
3697 3698 3699 3700 3701 3702 3703 | (if (dboard:tabdat-layout-update-ok tabdat) (testitemloop (car tidstal)(cdr tidstal)(+ item-num 1) new-test-objs) (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) ))))) ;; If it is an iterated test put box around it now. (if (not (null? tests-tal)) (if #f ;; (> (- (current-seconds) update-start-time) 5) | | | | | | 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 | (if (dboard:tabdat-layout-update-ok tabdat) (testitemloop (car tidstal)(cdr tidstal)(+ item-num 1) new-test-objs) (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) ))))) ;; If it is an iterated test put box around it now. (if (not (null? tests-tal)) (if #f ;; (> (- (current-seconds) update-start-time) 5) (debug:print 0 *default-log-port* "drawing runs taking too long") (if (dboard:tabdat-layout-update-ok tabdat) (testsloop (car tests-tal)(cdr tests-tal)(+ test-num 1)) (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) ))))) ;; placeholder box (dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat) 1)) ;; (let ((y (calc-y (dboard:tabdat-max-row tabdat)))) ;; (- sizey (* (dboard:tabdat-max-row tabdat) row-height)))) ;; (vg:add-obj-to-comp runcomp (vg:make-rect-obj 0 y 0 y))) ;; instantiate the component (let* ((extents (vg:components-get-extents drawing runcomp)) (new-xtnts (apply vg:grow-rect 5 5 extents)) (llx (list-ref new-xtnts 0)) (lly (list-ref new-xtnts 1)) (ulx (list-ref new-xtnts 2)) (uly (list-ref new-xtnts 3)) (outln (vg:make-rect-obj -5 lly ulx uly text: run-full-name line-color: (vg:rgb->number 255 0 255 a: 128)))) ; (vg:components-get-extents d1 c1))) ;; this is the box around the run ;; (mutex-lock! mtx) (vg:add-obj-to-comp runcomp outln) ;; (mutex-unlock! mtx) ;; this is where we have enough info to place the graph (dboard:graph commondat tabdat tab-num -5 (+ uly 10) ulx (+ uly graph-height 3) run-start run-end timescale maptime run-full-name canvas-margin) (dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat)(quotient (+ graph-height 40 3) row-height))) ;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat)) )) ;; end of the run handling loop (if (not (dboard:tabdat-layout-update-ok tabdat)) (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) (let ((newdoneruns (cons rundat doneruns))) (if (null? runtal) (begin (dboard:rundat-data-changed-set! rundat #f) (dboard:tabdat-not-done-runs-set! tabdat '()) (dboard:tabdat-done-runs-set! tabdat allruns)) (if #f ;; (> (- (current-seconds) update-start-time) 5) (begin (debug:print 0 *default-log-port* "drawing runs taking too long.... have " (length runtal) " remaining") ;; (dboard:tabdat-done-runs-set! tabdat newdoneruns) ;; taking too long? stop here! ;; (time (vg:draw (dboard:tabdat-drawing tabdat) #t)) (dboard:tabdat-not-done-runs-set! tabdat runtal)) (begin (if (dboard:tabdat-layout-update-ok tabdat) (runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns) (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) |
︙ | ︙ | |||
3794 3795 3796 3797 3798 3799 3800 3801 | )) "dashboard:runs-tab-updater")) ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== (define (main) | > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > | < < | | | | | | | | | | | | | | | | | > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 | )) "dashboard:runs-tab-updater")) ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== (stop-the-train) (define (main) ;; (print "Starting dashboard main") (let* ((mtdb-path (conc *toppath* "/.mtdb/main.db")) (target (args:get-arg "-target")) (commondat (dboard:commondat-make))) (if target (begin (hash-table-delete! args:arg-hash "-target") ;; workaround for the following commented out function ;; (args:remove-arg-from-ht "-target") This function is in mtargs/mtargs.scm, but it's in an egg that is not in the current build of chicken 4.10 (dboard:commondat-target-set! commondat target) ) ) (if (not (launch:setup)) (begin (debug:print 0 *default-log-port* "Failed to find megatest.config, exiting") (exit 1) ) ) #;(if (not (common:on-homehost?)) (begin (debug:print 0 *default-log-port* "WARNING: You are starting the dashboard on a machine that is not the homehost:" (server:get-homehost)) (debug:print 0 *default-log-port* "It will be slower.") )) (if (and (common:file-exists? mtdb-path) (file-write-access? mtdb-path)) (if (not (args:get-arg "-skip-version-check")) (common:exit-on-version-changed))) (let* () ;; Move this stuff to db.scm? I'm not sure that is the right thing to do... (cond ((args:get-arg "-test") ;; run-id,test-id (let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ",")))) (if (> (length d) 1) d (list #f #f)))) (run-id (car dat)) (test-id (cadr dat))) (if (and (number? run-id) (number? test-id) (>= test-id 0)) (dashboard-tests:examine-test run-id test-id) (begin (debug:print 3 *default-log-port* "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) (exit 1))))) (else (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 0)) tab-num: 0) ;; 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" (lambda (time-obj) (let ((update-is-running #f)) ;; (mutex-lock! (dboard:commondat-update-mutex commondat)) (set! update-is-running (dboard:commondat-updating commondat)) (if (not update-is-running) (dboard:commondat-updating-set! commondat #t)) ;; (mutex-unlock! (dboard:commondat-update-mutex commondat)) (if (not update-is-running) ;; we know that the update was not running and we now have a lock on doing an update (begin (dboard:common-run-curr-updaters commondat) ;; (dashboard:run-update commondat) ;; (mutex-lock! (dboard:commondat-update-mutex commondat)) (dboard:commondat-updating-set! commondat #f) ;; (mutex-unlock! (dboard:commondat-update-mutex commondat)) ))) 1)))) ;; (debug:print 0 *default-log-port* "Starting updaters") (let ((th1 (make-thread (lambda () (thread-sleep! 1) (dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab ) "update buttons once")) (th2 (make-thread iup:main-loop "Main loop"))) ;; (print "Starting main loop") (thread-start! th2) (thread-join! th2) ) ) ) ) (define last-copy-time 0) ;; Sync to tmp only if in read-only mode. (define (sync-db-to-tmp tabdat) (let* ((db-file "./.mtdb/main.db")) (if (and (not (file-write-access? db-file)) ( > (current-seconds) (+ last-copy-time 5))) (begin (db:multi-db-sync (db:setup) 'old2new) (set! last-copy-time (current-seconds)) ) ) ) ) ;; ########################### top level code ######################## ;; check for MT_* environment variables and exit if found (if (not (args:get-arg "-test")) (begin (for-each (lambda (var) ;; (display " ")(display var) (if (get-environment-variable var) (begin (debug:print 0 *default-log-port* "ERROR: environment variable " var " is set in this terminal, this will cause you problems. Exiting now.") (exit 1)))) '("MT_RUN_AREA_HOME" "MT_MEGATEST" "MT_CMDINFO" "MT_TEST_RUN_DIR" "MT_LINKTREE" "MT_TESTSUITENAME")) ) ) ;; This is NOT good ;; (setenv "MT_RUN_AREA_HOME" (get-environment-variable "PWD")) ;; This should be OK but it really should not be necessary (setenv "MT_RUN_AREA_HOME" (current-directory)) (if (not (null? remargs)) (if remargs (begin (debug:print 0 *default-log-port* "Unrecognised arguments: " (string-intersperse remargs " ")) (exit) ) (begin (print help) (exit) ) ) ) (if (args:get-arg "-h") (begin (print help) (exit))) (if (args:get-arg "-start-dir") (if (directory-exists? (args:get-arg "-start-dir")) (let ((fullpath (common:real-path (args:get-arg "-start-dir")))) (setenv "PWD" fullpath) (change-directory fullpath)) (begin (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") (exit 1)))) ;; deal with RH 5.11 gtk lib or iup lib missing detachbox feature ;; first check for the switch ;; (if (or (configf:lookup *configdat* "dashboard" "no-detachbox") (not (file-exists? "/etc/os-release"))) (set! iup:detachbox iup:vbox)) ;; ease debugging by loading ~/.dashboardrc (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (common:file-exists? debugcontrolf) (load debugcontrolf))) (if (args:get-arg "-repl") (repl) (main)) |
Modified datashare.scm from [2c1663032f] to [b486cc13b7].
︙ | ︙ | |||
12 13 14 15 16 17 18 | ;; 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/>. | > | | | | | | | | | | | | < | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | > | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > < | | | | | | | | | | | | | | | < > | < | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | ;; 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/>. ;; ==> (module datashare ;; ==> (use ssax) ;; ==> (use sxml-serializer) ;; ==> (use sxml-modifications) ;; ==> (use regex) ;; ==> (use srfi-69) ;; ==> (use regex-case) ;; ==> (use posix) ;; ==> (use json) ;; ==> (use csv) ;; ==> (use srfi-18) ;; ==> (use format) ;; ==> ;; ==> (use (prefix iup iup:)) ;; ==> (import (prefix ini-file ini:)) ;; ==> ;; ==> (use canvas-draw) ;; ==> (import canvas-draw-iup) ;; ==> ;; ==> (use sqlite3 srfi-1 posix regex regex-case srfi-69) ;; ==> (import (prefix sqlite3 sqlite3:)) ;; ==> ;; ==> (declare (uses configf)) ;; ==> (declare (uses tree)) ;; ==> (declare (uses margs)) ;; ==> ;; (declare (uses dcommon)) ;; ==> ;; (declare (uses launch)) ;; ==> ;; (declare (uses gutils)) ;; ==> ;; (declare (uses db)) ;; ==> ;; (declare (uses synchash)) ;; ==> ;; (declare (uses server)) ;; ==> ;; (declare (uses megatest-version)) ;; ==> ;; (declare (uses tbd)) ;; ==> ;; ==> (include "megatest-fossil-hash.scm") ;; ==> ;; ==> ;; ;; ==> ;; GLOBALS ;; ==> ;; ;; ==> (define *datashare:current-tab-number* 0) ;; ==> (define *args-hash* (make-hash-table)) ;; ==> (define datashare:help (conc "Usage: datashare [action [params ...]] ;; ==> ;; ==> Note: run datashare without parameters to start the gui. ;; ==> ;; ==> list-areas : List the allowed areas ;; ==> ;; ==> list-versions <area> : List versions available in <area> ;; ==> options : -full, -vpatt patt ;; ==> ;; ==> publish <path> <area> <version> : Publish data for area and with version ;; ==> ;; ==> get <area> <version> : Get a link to data, put the link in destpath ;; ==> options : -i iteration ;; ==> ;; ==> update <area> : Update the link to data to the latest iteration. ;; ==> ;; ==> Part of the Megatest tool suite. ;; ==> Learn more at http://www.kiatoa.com/fossils/megatest ;; ==> ;; ==> Version: " megatest-fossil-hash)) ;; " ;; ==> ;; ==> ;;====================================================================== ;; ==> ;; RECORDS ;; ==> ;;====================================================================== ;; ==> ;; ==> ;; make-vector-record "testing" datastore pkg id area version_name store_type copied source_path iteration submitter datetime storegrp datavol quality disk_id comment ;; ==> ;; testing ;; ==> (define (make-datashare:pkg)(make-vector 15)) ;; ==> (define-inline (datashare:pkg-get-id vec) (vector-ref vec 0)) ;; ==> (define-inline (datashare:pkg-get-area vec) (vector-ref vec 1)) ;; ==> (define-inline (datashare:pkg-get-version_name vec) (vector-ref vec 2)) ;; ==> (define-inline (datashare:pkg-get-store_type vec) (vector-ref vec 3)) ;; ==> (define-inline (datashare:pkg-get-copied vec) (vector-ref vec 4)) ;; ==> (define-inline (datashare:pkg-get-source_path vec) (vector-ref vec 5)) ;; ==> (define-inline (datashare:pkg-get-iteration vec) (vector-ref vec 6)) ;; ==> (define-inline (datashare:pkg-get-submitter vec) (vector-ref vec 7)) ;; ==> (define-inline (datashare:pkg-get-datetime vec) (vector-ref vec 8)) ;; ==> (define-inline (datashare:pkg-get-storegrp vec) (vector-ref vec 9)) ;; ==> (define-inline (datashare:pkg-get-datavol vec) (vector-ref vec 10)) ;; ==> (define-inline (datashare:pkg-get-quality vec) (vector-ref vec 11)) ;; ==> (define-inline (datashare:pkg-get-disk_id vec) (vector-ref vec 12)) ;; ==> (define-inline (datashare:pkg-get-comment vec) (vector-ref vec 13)) ;; ==> (define-inline (datashare:pkg-get-stored_path vec) (vector-ref vec 14)) ;; ==> (define-inline (datashare:pkg-set-id! vec val)(vector-set! vec 0 val)) ;; ==> (define-inline (datashare:pkg-set-area! vec val)(vector-set! vec 1 val)) ;; ==> (define-inline (datashare:pkg-set-version_name! vec val)(vector-set! vec 2 val)) ;; ==> (define-inline (datashare:pkg-set-store_type! vec val)(vector-set! vec 3 val)) ;; ==> (define-inline (datashare:pkg-set-copied! vec val)(vector-set! vec 4 val)) ;; ==> (define-inline (datashare:pkg-set-source_path! vec val)(vector-set! vec 5 val)) ;; ==> (define-inline (datashare:pkg-set-iteration! vec val)(vector-set! vec 6 val)) ;; ==> (define-inline (datashare:pkg-set-submitter! vec val)(vector-set! vec 7 val)) ;; ==> (define-inline (datashare:pkg-set-datetime! vec val)(vector-set! vec 8 val)) ;; ==> (define-inline (datashare:pkg-set-storegrp! vec val)(vector-set! vec 9 val)) ;; ==> (define-inline (datashare:pkg-set-datavol! vec val)(vector-set! vec 10 val)) ;; ==> (define-inline (datashare:pkg-set-quality! vec val)(vector-set! vec 11 val)) ;; ==> (define-inline (datashare:pkg-set-disk_id! vec val)(vector-set! vec 12 val)) ;; ==> (define-inline (datashare:pkg-set-comment! vec val)(vector-set! vec 13 val)) ;; ==> (define-inline (datashare:pkg-set-stored_path! vec val)(vector-set! vec 14 val)) ;; ==> ;; ==> ;;====================================================================== ;; ==> ;; DB ;; ==> ;;====================================================================== ;; ==> ;; ==> (define (datashare:initialize-db db) ;; ==> (for-each ;; ==> (lambda (qry) ;; ==> (sqlite3:execute db qry)) ;; ==> (list ;; ==> "CREATE TABLE pkgs ;; ==> (id INTEGER PRIMARY KEY, ;; ==> area TEXT, ;; ==> version_name TEXT, ;; ==> store_type TEXT DEFAULT 'copy', ;; ==> copied INTEGER DEFAULT 0, ;; ==> source_path TEXT, ;; ==> stored_path TEXT, ;; ==> iteration INTEGER DEFAULT 0, ;; ==> submitter TEXT, ;; ==> datetime TIMESTAMP DEFAULT (strftime('%s','now')), ;; ==> storegrp TEXT, ;; ==> datavol INTEGER, ;; ==> quality TEXT, ;; ==> disk_id INTEGER, ;; ==> comment TEXT);" ;; ==> "CREATE TABLE refs ;; ==> (id INTEGER PRIMARY KEY, ;; ==> pkg_id INTEGER, ;; ==> destlink TEXT);" ;; ==> "CREATE TABLE disks ;; ==> (id INTEGER PRIMARY KEY, ;; ==> storegrp TEXT, ;; ==> path TEXT);"))) ;; ==> ;; ==> (define (datashare:register-data db area version-name store-type submitter quality source-path comment) ;; ==> (let ((iter-qry (sqlite3:prepare db "SELECT max(iteration) FROM pkgs WHERE area=? AND version_name=?;")) ;; ==> (next-iteration 0)) ;; ==> (sqlite3:with-transaction ;; ==> db ;; ==> (lambda () ;; ==> (sqlite3:for-each-row ;; ==> (lambda (iteration) ;; ==> (if (and (number? iteration) ;; ==> (>= iteration next-iteration)) ;; ==> (set! next-iteration (+ iteration 1)))) ;; ==> iter-qry area version-name) ;; ==> ;; now store the data ;; ==> (sqlite3:execute db "INSERT INTO pkgs (area,version_name,iteration,store_type,submitter,source_path,quality,comment) ;; ==> VALUES (?,?,?,?,?,?,?,?);" ;; ==> area version-name next-iteration (conc store-type) submitter source-path quality comment))) ;; ==> (sqlite3:finalize! iter-qry) ;; ==> next-iteration)) ;; ==> ;; ==> (define (datashare:get-id db area version-name iteration) ;; ==> (let ((res #f)) ;; ==> (sqlite3:for-each-row ;; ==> (lambda (id) ;; ==> (set! res id)) ;; ==> db ;; ==> "SELECT id FROM pkgs WHERE area=? AND version_name=? AND iteration=?;" ;; ==> area version-name iteration) ;; ==> res)) ;; ==> ;; ==> (define (datashare:set-stored-path db id path) ;; ==> (sqlite3:execute db "UPDATE pkgs SET stored_path=? WHERE id=?;" path id)) ;; ==> ;; ==> (define (datashare:set-copied db id value) ;; ==> (sqlite3:execute db "UPDATE pkgs SET copied=? WHERE id=?;" value id)) ;; ==> ;; ==> (define (datashare:get-pkg-record db area version-name iteration) ;; ==> (let ((res #f)) ;; ==> (sqlite3:for-each-row ;; ==> (lambda (a . b) ;; ==> (set! res (apply vector a b))) ;; ==> db ;; ==> "SELECT * FROM pkgs WHERE area=? AND version_name=? AND iteration=?;" ;; ==> area ;; ==> version-name ;; ==> iteration) ;; ==> res)) ;; ==> ;; ==> ;; take version-name iteration and register or update "lastest/0" ;; ==> ;; ;; ==> (define (datashare:set-latest db id area version-name iteration) ;; ==> (let* ((rec (datashare:get-pkg-record db area version-name iteration)) ;; ==> (latest-id (datashare:get-id db area "latest" 0)) ;; ==> (stored-path (datashare:pkg-get-stored_path rec))) ;; ==> (if latest-id ;; have a record - bump the link pointer ;; ==> (datashare:set-stored-path db latest-id stored-path) ;; ==> (datashare:register-data db area "latest" 'link "auto" "na" stored-path "latest data")))) ;; ==> ;; ==> ;; set a package ref, this is the location where the link back to the stored data ;; ==> ;; is put. ;; ==> ;; ;; ==> ;; if there is nothing at that location then the record can be removed ;; ==> ;; if there are no refs for a particular pkg-id then that pkg-id is a ;; ==> ;; candidate for removal ;; ==> ;; ;; ==> (define (datashare:record-pkg-ref db pkg-id dest-link) ;; ==> (sqlite3:execute db "INSERT INTO refs (pkg_id,destlink) VALUES (?,?);" pkg-id dest-link)) ;; ==> ;; ==> (define (datashare:count-refs db pkg-id) ;; ==> (let ((res 0)) ;; ==> (sqlite3:for-each-row ;; ==> (lambda (count) ;; ==> (set! res count)) ;; ==> db ;; ==> "SELECT count(id) FROM refs WHERE pkg_id=?;" ;; ==> pkg-id) ;; ==> res)) ;; ==> ;; ==> ;; Create the sqlite db ;; ==> (define (datashare:open-db configdat) ;; ==> (let ((path (configf:lookup configdat "database" "location"))) ;; ==> (if (and path ;; ==> (directory? path) ;; ==> (file-read-access? path)) ;; ==> (let* ((dbpath (conc path "/datashare.db")) ;; ==> (writeable (file-write-access? dbpath)) ;; ==> (dbexists (common:file-exists? dbpath)) ;; ==> (handler (make-busy-timeout 136000))) ;; ==> (handle-exceptions ;; ==> exn ;; ==> (begin ;; ==> (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath ;; ==> ((condition-property-accessor 'exn 'message) exn)) ;; ==> (exit)) ;; ==> (set! db (sqlite3:open-database dbpath))) ;; ==> (if *db-write-access* (sqlite3:set-busy-handler! db handler)) ;; ==> (if (not dbexists) ;; ==> (begin ;; ==> (datashare:initialize-db db))) ;; ==> db) ;; ==> (print "ERROR: invalid path for storing database: " path)))) ;; ==> ;; ==> (define (open-run-close-exception-handling proc idb . params) ;; ==> (handle-exceptions ;; ==> exn ;; ==> (let ((sleep-time (random 30)) ;; ==> (err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; ==> (case err-status ;; ==> ((busy) ;; ==> (thread-sleep! sleep-time)) ;; ==> (else ;; ==> (print "EXCEPTION: database overloaded or unreadable.") ;; ==> (print " message: " ((condition-property-accessor 'exn 'message) exn)) ;; ==> (print "exn=" (condition->list exn)) ;; ==> (print " status: " ((condition-property-accessor 'sqlite3 'status) exn)) ;; ==> (print-call-chain (current-error-port)) ;; ==> (thread-sleep! sleep-time) ;; ==> (print "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up"))) ;; ==> (apply open-run-close-exception-handling proc idb params)) ;; ==> (apply open-run-close-no-exception-handling proc idb params))) ;; ==> ;; ==> (define (open-run-close-no-exception-handling proc idb . params) ;; ==> ;; (print "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) ;; ==> (let* ((db (cond ;; ==> ((sqlite3:database? idb) idb) ;; ==> ((not idb) (print "ERROR: cannot open-run-close with #f anymore")) ;; ==> ((procedure? idb) (idb)) ;; ==> (else (print "ERROR: cannot open-run-close with #f anymore")))) ;; ==> (res #f)) ;; ==> (set! res (apply proc db params)) ;; ==> (if (not idb)(sqlite3:finalize! dbstruct)) ;; ==> ;; (print "open-run-close-no-exception-handling END" ) ;; ==> res)) ;; ==> ;; ==> (define open-run-close open-run-close-no-exception-handling) ;; ==> ;; ==> (define (datashare:get-pkgs db area-filter version-filter iter-filter) ;; ==> (let ((res '())) ;; ==> (sqlite3:for-each-row ;; replace with fold ... ;; ==> (lambda (a . b) ;; ==> (set! res (cons (list->vector (cons a b)) res))) ;; ==> db ;; ==> (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path " ;; ==> " FROM pkgs WHERE area like ? AND version_name LIKE ? AND iteration " iter-filter ";") ;; ==> area-filter version-filter) ;; ==> (reverse res))) ;; ==> ;; ==> (define (datashare:get-pkg db area-name version-name #!key (iteration #f)) ;; ==> (let ((dat '()) ;; ==> (res #f)) ;; ==> (sqlite3:for-each-row ;; replace with fold ... ;; ==> (lambda (a . b) ;; ==> (set! dat (cons (list->vector (cons a b)) dat))) ;; ==> db ;; ==> (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path " ;; ==> " FROM pkgs WHERE area=? AND version_name=? ORDER BY iteration ASC;") ;; ==> area-name version-name) ;; ==> ;; now filter for iteration, either max if #f or specific one ;; ==> (if (null? dat) ;; ==> #f ;; ==> (let loop ((hed (car dat)) ;; ==> (tal (cdr dat)) ;; ==> (cur 0)) ;; ==> (let ((itr (datashare:pkg-get-iteration hed))) ;; ==> (if (equal? itr iteration) ;; this is the one if iteration is specified ;; ==> hed ;; ==> (if (null? tal) ;; ==> hed ;; ==> (loop (car tal)(cdr tal))))))))) ;; ==> ;; ==> (define (datashare:get-versions-for-area db area-name #!key (version-patt #f)) ;; ==> (let ((res '()) ;; ==> (data (make-hash-table))) ;; ==> (sqlite3:for-each-row ;; ==> (lambda (version-name submitter iteration submitted-time comment) ;; ==> ;; 0 1 2 3 4 ;; ==> (hash-table-set! data version-name (vector version-name submitter iteration submitted-time comment))) ;; ==> db ;; ==> "SELECT version_name,submitter,iteration,datetime,comment FROM pkgs WHERE area='megatest' AND version_name != 'latest' AND version_name LIKE ? ORDER BY datetime asc;" ;; ==> (or version-patt "%")) ;; ==> (map (lambda (x)(hash-table-ref data x))(sort (hash-table-keys data) string-ci>=)))) ;; ==> ;; ==> ;;====================================================================== ;; ==> ;; DATA IMPORT/EXPORT ;; ==> ;;====================================================================== ;; ==> ;; ==> (define (datashare:import-data configdat source-path dest-path area version iteration) ;; ==> (let* ((space-avail (car dest-path)) ;; ==> (disk-path (cdr dest-path)) ;; ==> (targ-path (conc disk-path "/" area "/" version "/" iteration)) ;; ==> (id (datashare:get-id db area version iteration)) ;; ==> (db (datashare:open-db configdat))) ;; ==> (if (> space-avail 10000) ;; dumb heuristic ;; ==> (begin ;; ==> (create-directory targ-path #t) ;; ==> (datashare:set-stored-path db id targ-path) ;; ==> (print "Running command: rsync -av " source-path "/ " targ-path "/") ;; ==> (let ((th1 (make-thread (lambda () ;; ==> (let ((pid (process-run "rsync" (list "-av" (conc source-path "/") (conc targ-path "/"))))) ;; ==> (process-wait pid) ;; ==> (datashare:set-copied db id "yes") ;; ==> (sqlite3:finalize! db))) ;; ==> "Data copy"))) ;; ==> (thread-start! th1)) ;; ==> #t) ;; ==> (begin ;; ==> (print "ERROR: Not enough space in storage area " dest-path) ;; ==> (datashare:set-copied db id "no") ;; ==> (sqlite3:finalize! db) ;; ==> #f)))) ;; ==> ;; ==> (define (datashare:get-areas configdat) ;; ==> (let* ((areadat (configf:get-section configdat "areas")) ;; ==> (areas (if areadat (map car areadat) '()))) ;; ==> areas)) ;; ==> ;; ==> (define (datashare:publish configdat publish-type area-name version comment spath submitter quality) ;; ==> ;; input checks ;; ==> (cond ;; ==> ((not (member area-name (datashare:get-areas configdat))) ;; ==> (cons #f (conc "Illegal area name \"" area-name "\""))) ;; ==> (else ;; ==> (let ((db (datashare:open-db configdat)) ;; ==> (iteration (datashare:register-data db area-name version publish-type submitter quality spath comment)) ;; ==> (dest-store (datashare:get-best-storage configdat))) ;; ==> (if iteration ;; ==> (if (eq? 'copy publish-type) ;; ==> (begin ;; ==> (datashare:import-data configdat spath dest-store area-name version iteration) ;; ==> (let ((id (datashare:get-id db area-name version iteration))) ;; ==> (datashare:set-latest db id area-name version iteration))) ;; ==> (let ((id (datashare:get-id db area-name version iteration))) ;; ==> (datashare:set-stored-path db id spath) ;; ==> (datashare:set-copied db id "yes") ;; ==> (datashare:set-copied db id "n/a") ;; ==> (datashare:set-latest db id area-name version iteration))) ;; ==> (print "ERROR: Failed to get an iteration number")) ;; ==> (sqlite3:finalize! db) ;; ==> (cons #t "Successfully saved data"))))) ;; ==> ;; ==> (define (datashare:get-best-storage configdat) ;; ==> (let* ((storage (configf:lookup configdat "settings" "storage")) ;; ==> (store-areas (if storage (string-split storage) '()))) ;; ==> (print "Looking for available space in " store-areas) ;; ==> (datashare:find-most-space store-areas))) ;; ==> ;; ==> ;; (string->number (list-ref (with-input-from-pipe "df -B1000000 /tmp" (lambda ()(read-line)(string-split (read-line)))) 3)) ;; ==> ;; ==> (define (datashare:find-most-space paths) ;; ==> (fold (lambda (area res) ;; ==> ;; (print "area=" area " res=" res) ;; ==> (let ((maxspace (car res)) ;; ==> (currpath (cdr res))) ;; ==> ;; (print currpath " " maxspace) ;; ==> (if (file-write-access? area) ;; ==> (let ((currspace (string->number ;; ==> (list-ref ;; ==> (with-input-from-pipe ;; ==> ;; (conc "df --output=avail " area) ;; ==> (conc "df -B1000000 " area) ;; ==> ;; (lambda ()(read)(read)) ;; ==> (lambda ()(read-line)(string-split (read-line)))) ;; ==> 3)))) ;; ==> (if (> currspace maxspace) ;; ==> (cons currspace area) ;; ==> res)) ;; ==> res))) ;; ==> (cons 0 #f) ;; ==> paths)) ;; ==> ;; ==> ;; remove existing link and if possible ... ;; ==> ;; create path to next of tip of target, create link back to source ;; ==> (define (datashare:build-dir-make-link source target) ;; ==> (if (common:file-exists? target)(datashare:backup-move target)) ;; ==> (create-directory (pathname-directory target) #t) ;; ==> (create-symbolic-link source target)) ;; ==> ;; ==> (define (datashare:backup-move path) ;; ==> (let* ((trashdir (conc (pathname-directory path) "/.trash")) ;; ==> (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path)))) ;; ==> (create-directory trashdir #t) ;; ==> (if (directory? path) ;; ==> (system (conc "mv " path " " trashfile)) ;; ==> (file-move path trash-file)))) ;; ==> ;; ==> ;;====================================================================== ;; ==> ;; GUI ;; ==> ;;====================================================================== ;; ==> ;; ==> ;; The main menu ;; ==> (define (datashare:main-menu) ;; ==> (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top) ;; ==> (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options ;; ==> (iup:menu-item "Open" action: (lambda (obj) ;; ==> (iup:show (iup:file-dialog)) ;; ==> (print "File->open " obj))) ;; ==> (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj))) ;; ==> (iup:menu-item "Exit" #:action (lambda (obj)(exit))))) ;; ==> (iup:menu-item "Tools" (iup:menu ;; ==> (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah"))) ;; ==> ;; (iup:menu-item "Show dialog" #:action (lambda (obj) ;; ==> ;; (show message-window ;; ==> ;; #:modal? #t ;; ==> ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current ;; ==> ;; ;; #:x 'mouse ;; ==> ;; ;; #:y 'mouse ;; ==> ;; ) ;; ==> )))) ;; ==> ;; ==> (define (datashare:publish-view configdat) ;; ==> ;; (pp (hash-table->alist configdat)) ;; ==> (let* ((areas (configf:get-section configdat "areas")) ;; ==> (label-size "70x") ;; ==> (areas-sel (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES")) ;; ==> (version-tb (iup:textbox #:expand "HORIZONTAL")) ;; #:size "50x")) ;; ==> (areas-sel (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES")) ;; ==> (component (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" )) ;; ==> (version-val (iup:textbox #:expand "HORIZONTAL" #:size "50x")) ;; ==> ;; (copy-link (iup:toggle #:expand "HORIZONTAL")) ;; ==> ;; (iteration (iup:textbox #:expand "YES" #:size "20x")) ;; ==> ;; (iteration (iup:textbox #:expand "HORIZONTAL" #:size "20x")) ;; ==> (area-filter (iup:textbox #:expand "HORIZONTAL" #:value "%")) ;; ==> (comment-tb (iup:textbox #:expand "YES" #:multiline "YES")) ;; ==> (source-tb (iup:textbox #:expand "HORIZONTAL" ;; ==> #:value (or (configf:lookup configdat "settings" "basepath") ;; ==> ""))) ;; ==> (publish (lambda (publish-type) ;; ==> (let* ((area-num (or (string->number (iup:attribute areas-sel "VALUE")) 0)) ;; ==> (area-dat (if (> area-num 0)(list-ref areas (- area-num 1))'("NOT SELECTED" "NOT SELECTED"))) ;; ==> (area-path (cadr area-dat)) ;; ==> (area-name (car area-dat)) ;; ==> (version (iup:attribute version-tb "VALUE")) ;; ==> (comment (iup:attribute comment-tb "VALUE")) ;; ==> (spath (iup:attribute source-tb "VALUE")) ;; ==> (submitter (current-user-name)) ;; ==> (quality 2)) ;; ==> (datashare:publish configdat publish-type area-name version comment spath submitter quality)))) ;; ==> (copy (iup:button "Copy and Publish" ;; ==> #:expand "HORIZONTAL" ;; ==> #:action (lambda (obj) ;; ==> (publish 'copy)))) ;; ==> (link (iup:button "Link and Publish" ;; ==> #:expand "HORIZONTAL" ;; ==> #:action (lambda (obj) ;; ==> (publish 'link)))) ;; ==> (browse-btn (iup:button "Browse" ;; ==> #:size "40x" ;; ==> #:action (lambda (obj) ;; ==> (let* ((fd (iup:file-dialog #:dialogtype "DIR")) ;; ==> (top (iup:show fd #:modal? "YES"))) ;; ==> (iup:attribute-set! source-tb "VALUE" ;; ==> (iup:attribute fd "VALUE")) ;; ==> (iup:destroy! fd)))))) ;; ==> (print "areas") ;; ==> ;; (pp areas) ;; ==> (fold (lambda (areadat num) ;; ==> ;; (print "Adding num=" num ", areadat=" areadat) ;; ==> (iup:attribute-set! areas-sel (conc num) (car areadat)) ;; ==> (+ 1 num)) ;; ==> 1 areas) ;; ==> (iup:vbox ;; ==> (iup:hbox (iup:label "Area:" #:size label-size) ;; area-filter ;; ==> areas-sel) ;; ==> (iup:hbox (iup:label "Version:" #:size label-size) version-tb) ;; ==> ;; (iup:hbox (iup:label "Link only" #:size label-size) copy-link) ;; ==> ;; (iup:label "Iteration:") iteration) ;; ==> (iup:hbox (iup:label "Comment:" #:size label-size) comment-tb) ;; ==> (iup:hbox (iup:label "Source base path:" #:size label-size) source-tb browse-btn) ;; ==> (iup:hbox copy link)))) ;; ==> ;; ==> (define (datashare:lst->path pathlst) ;; ==> (conc "/" (string-intersperse (map conc pathlst) "/"))) ;; ==> ;; ==> (define (datashare:path->lst path) ;; ==> (string-split path "/")) ;; ==> ;; ==> (define (datashare:pathdat-apply-heuristics configdat path) ;; ==> (cond ;; ==> ((common:file-exists? path) "found") ;; ==> (else (conc path " not installed")))) ;; ==> ;; ==> (define (datashare:get-view configdat) ;; ==> (iup:vbox ;; ==> (iup:hbox ;; ==> (let* ((label-size "60x") ;; ==> ;; filter elements ;; ==> (area-filter "%") ;; ==> (version-filter "%") ;; ==> (iter-filter ">= 0") ;; ==> ;; reverse lookup from path to data for src and installed ;; ==> (srcdat (make-hash-table)) ;; reverse lookup ;; ==> (installed-dat (make-hash-table)) ;; ==> ;; config values ;; ==> (basepath (configf:lookup configdat "settings" "basepath")) ;; ==> ;; gui elements ;; ==> (submitter (iup:label "" #:expand "HORIZONTAL")) ;; ==> (date-submitted (iup:label "" #:expand "HORIZONTAL")) ;; ==> (comment (iup:label "" #:expand "HORIZONTAL")) ;; ==> (copy-link (iup:label "" #:expand "HORIZONTAL")) ;; ==> (quality (iup:label "" #:expand "HORIZONTAL")) ;; ==> (installed-status (iup:label "" #:expand "HORIZONTAL")) ;; ==> ;; misc ;; ==> (curr-record #f) ;; ==> ;; (source-data (iup:label "" #:expand "HORIZONTAL")) ;; ==> (tb (iup:treebox ;; ==> #:value 0 ;; ==> #:name "Packages" ;; ==> #:expand "YES" ;; ==> #:addexpanded "NO" ;; ==> #:selection-cb ;; ==> (lambda (obj id state) ;; ==> ;; (print "obj: " obj ", id: " id ", state: " state) ;; ==> (let* ((path (datashare:lst->path (cdr (tree:node->path obj id)))) ;; ==> (record (hash-table-ref/default srcdat path #f))) ;; ==> (if record ;; ==> (begin ;; ==> (set! curr-record record) ;; ==> (iup:attribute-set! submitter "TITLE" (datashare:pkg-get-submitter record)) ;; ==> (iup:attribute-set! date-submitted "TITLE" (time->string (seconds->local-time (datashare:pkg-get-datetime record)))) ;; ==> (iup:attribute-set! comment "TITLE" (datashare:pkg-get-comment record)) ;; ==> (iup:attribute-set! quality "TITLE" (datashare:pkg-get-quality record)) ;; ==> (iup:attribute-set! copy-link "TITLE" (datashare:pkg-get-store_type record)) ;; ==> )) ;; ==> ;; (print "id=" id " path=" path " record=" record);; (tree:node->path obj id) " run-id: " run-id) ;; ==> )))) ;; ==> (tb2 (iup:treebox ;; ==> #:value 0 ;; ==> #:name "Installed" ;; ==> #:expand "YES" ;; ==> #:addexpanded "NO" ;; ==> #:selection-cb ;; ==> (lambda (obj id state) ;; ==> ;; (print "obj: " obj ", id: " id ", state: " state) ;; ==> (let* ((path (datashare:lst->path (cdr (tree:node->path obj id)))) ;; ==> (status (hash-table-ref/default installed-dat path #f))) ;; ==> (iup:attribute-set! installed-status "TITLE" (if status status "")) ;; ==> )))) ;; ==> (refresh (lambda (obj) ;; ==> (let* ((db (datashare:open-db configdat)) ;; ==> (areas (or (configf:get-section configdat "areas") '()))) ;; ==> ;; ;; ==> ;; first update the Sources ;; ==> ;; ;; ==> (for-each ;; ==> (lambda (pkgitem) ;; ==> (let* ((pkg-path (list (datashare:pkg-get-area pkgitem) ;; ==> (datashare:pkg-get-version_name pkgitem) ;; ==> (datashare:pkg-get-iteration pkgitem))) ;; ==> (pkg-id (datashare:pkg-get-id pkgitem)) ;; ==> (path (datashare:lst->path pkg-path))) ;; ==> ;; (print "tree:add-node tb=" tb ", pkg-path=" pkg-path ", pkg-id=" pkg-id) ;; ==> (if (not (hash-table-ref/default srcdat path #f)) ;; ==> (tree:add-node tb "Packages" pkg-path userdata: (conc "pkg-id: " pkg-id))) ;; ==> ;; (print "path=" path " pkgitem=" pkgitem) ;; ==> (hash-table-set! srcdat path pkgitem))) ;; ==> (datashare:get-pkgs db area-filter version-filter iter-filter)) ;; ==> ;; ;; ==> ;; then update the installed ;; ==> ;; ;; ==> (for-each ;; ==> (lambda (area) ;; ==> (let* ((path (conc "/" (cadr area))) ;; ==> (fullpath (conc basepath path))) ;; ==> (if (not (hash-table-ref/default installed-dat path #f)) ;; ==> (tree:add-node tb2 "Installed" (datashare:path->lst path))) ;; ==> (hash-table-set! installed-dat path (datashare:pathdat-apply-heuristics configdat fullpath)))) ;; ==> areas) ;; ==> (sqlite3:finalize! db)))) ;; ==> (apply (iup:button "Apply" ;; ==> #:action ;; ==> (lambda (obj) ;; ==> (if curr-record ;; ==> (let* ((area (datashare:pkg-get-area curr-record)) ;; ==> (stored-path (datashare:pkg-get-stored_path curr-record)) ;; ==> (source-type (datashare:pkg-get-store_type curr-record)) ;; ==> (source-path (case source-type ;; (equal? source-type "link")) ;; ==> ((link)(datashare:pkg-get-source-path curr-record)) ;; ==> ((copy)stored-path) ;; ==> (else #f))) ;; ==> (dest-stub (configf:lookup configdat "areas" area)) ;; ==> (target-path (conc basepath "/" dest-stub))) ;; ==> (datashare:build-dir-make-link stored-path target-path) ;; ==> (print "Creating link from " stored-path " to " target-path))))))) ;; ==> (iup:vbox ;; ==> (iup:hbox tb tb2) ;; ==> (iup:frame ;; ==> #:title "Source Info" ;; ==> (iup:vbox ;; ==> (iup:hbox (iup:button "Refresh" #:action refresh) apply) ;; ==> (iup:hbox (iup:label "Submitter: ") ;; #:size label-size) ;; ==> submitter ;; ==> (iup:label "Submitted on: ") ;; #:size label-size) ;; ==> date-submitted) ;; ==> (iup:hbox (iup:label "Data stored: ") ;; ==> copy-link ;; ==> (iup:label "Quality: ") ;; ==> quality) ;; ==> (iup:hbox (iup:label "Comment: ") ;; ==> comment))) ;; ==> (iup:frame ;; ==> #:title "Installed Info" ;; ==> (iup:vbox ;; ==> (iup:hbox (iup:label "Installed status/path: ") installed-status))) ;; ==> ))))) ;; ==> ;; ==> (define (datashare:manage-view configdat) ;; ==> (iup:vbox ;; ==> (iup:hbox ;; ==> (iup:button "Pushme" ;; ==> #:expand "YES" ;; ==> )))) ;; ==> ;; ==> (define (datashare:gui configdat) ;; ==> (iup:show ;; ==> (iup:dialog ;; ==> #:title (conc "DataShare dashboard " (current-user-name) ":" (current-directory)) ;; ==> #:menu (datashare:main-menu) ;; ==> (let* ((tabs (iup:tabs ;; ==> #:tabchangepos-cb (lambda (obj curr prev) ;; ==> (set! *datashare:current-tab-number* curr)) ;; ==> (datashare:publish-view configdat) ;; ==> (datashare:get-view configdat) ;; ==> (datashare:manage-view configdat) ;; ==> ))) ;; ==> ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) ;; ==> (iup:attribute-set! tabs "TABTITLE0" "Publish") ;; ==> (iup:attribute-set! tabs "TABTITLE1" "Get") ;; ==> (iup:attribute-set! tabs "TABTITLE2" "Manage") ;; ==> ;; (iup:attribute-set! tabs "BGCOLOR" "190 190 190") ;; ==> tabs))) ;; ==> (iup:main-loop)) ;; ==> ;; ==> ;;====================================================================== ;; ==> ;; MISC ;; ==> ;;====================================================================== ;; ==> ;; ==> ;; ==> (define (datashare:do-as-calling-user proc) ;; ==> (let ((eid (current-effective-user-id)) ;; ==> (cid (current-user-id))) ;; ==> (if (not (eq? eid cid)) ;; running suid ;; ==> (set! (current-effective-user-id) cid)) ;; ==> ;; (print "running as " (current-effective-user-id)) ;; ==> (proc) ;; ==> (if (not (eq? eid cid)) ;; ==> (set! (current-effective-user-id) eid)))) ;; ==> ;; ==> (define (datashare:find name paths) ;; ==> (if (null? paths) ;; ==> #f ;; ==> (let loop ((hed (car paths)) ;; ==> (tal (cdr paths))) ;; ==> (if (common:file-exists? (conc hed "/" name)) ;; ==> hed ;; ==> (if (null? tal) ;; ==> #f ;; ==> (loop (car tal)(cdr tal))))))) ;; ==> ;; ==> ;;====================================================================== ;; ==> ;; MAIN ;; ==> ;;====================================================================== ;; ==> ;; ==> (define (datashare:load-config exe-dir exe-name) ;; ==> (let* ((fname (conc exe-dir "/." exe-name ".config"))) ;; ==> (ini:property-separator-patt " * *") ;; ==> (ini:property-separator #\space) ;; ==> (if (common:file-exists? fname) ;; ==> ;; (ini:read-ini fname) ;; ==> (read-config fname #f #t) ;; ==> (make-hash-table)))) ;; ==> ;; ==> (define (datashare:process-action configdat action . args) ;; ==> (case (string->symbol action) ;; ==> ((get) ;; ==> (if (< (length args) 2) ;; ==> (begin ;; ==> (print "ERROR: Missing arguments; " (string-intersperse args ", ")) ;; ==> (exit 1)) ;; ==> (let* ((basepath (configf:lookup configdat "settings" "basepath")) ;; ==> (db (datashare:open-db configdat)) ;; ==> (area (car args)) ;; ==> (version (cadr args)) ;; iteration ;; ==> (remargs (args:get-args args '("-i") '() args:arg-hash 0)) ;; ==> (iteration (if (args:get-arg "-i")(string->number (args:get-arg "-i")) #f)) ;; ==> (curr-record (datashare:get-pkg db area version iteration: iteration))) ;; ==> (if (not curr-record) ;; ==> (begin ;; ==> (print "ERROR: No matching record found; area=" area ", version=" version ", iteration=" (if iteration iteration "(max)")) ;; ==> (exit 1)) ;; ==> (let* ((stored-path (datashare:pkg-get-stored_path curr-record)) ;; ==> (source-type (datashare:pkg-get-store_type curr-record)) ;; ==> (source-path (case source-type ;; (equal? source-type "link")) ;; ==> ((link) (datashare:pkg-get-source-path curr-record)) ;; ==> ((copy) stored-path) ;; ==> (else #f))) ;; ==> (dest-stub (configf:lookup configdat "areas" area)) ;; ==> (target-path (conc basepath "/" dest-stub))) ;; ==> (datashare:build-dir-make-link stored-path target-path) ;; ==> (datashare:record-pkg-ref db (datashare:pkg-get-id curr-record) target-path) ;; ==> (sqlite3:finalize! db) ;; ==> (print "Creating link from " stored-path " to " target-path)))))) ;; ==> ((publish) ;; ==> (if (< (length args) 3) ;; ==> (begin ;; ==> (print "ERROR: Missing arguments; " (string-intersperse args ", ")) ;; ==> (exit 1)) ;; ==> (let* ((srcpath (list-ref args 0)) ;; ==> (areaname (list-ref args 1)) ;; ==> (version (list-ref args 2)) ;; ==> (remargs (args:get-args (drop args 2) ;; ==> '("-type" ;; link or copy (default is copy) ;; ==> "-m") ;; ==> '() ;; ==> args:arg-hash ;; ==> 0)) ;; ==> (publish-type (if (equal? (args:get-arg "-type") "link") 'link 'copy)) ;; ==> (comment (or (args:get-arg "-m") "")) ;; ==> (submitter (current-user-name)) ;; ==> (quality (args:get-arg "-quality")) ;; ==> (publish-res (datashare:publish configdat publish-type areaname version comment srcpath submitter quality))) ;; ==> (if (not (car publish-res)) ;; ==> (begin ;; ==> (print "ERROR: " (cdr publish-res)) ;; ==> (exit 1)))))) ;; ==> ((list-versions) ;; ==> (let ((area-name (car args)) ;; version patt full print ;; ==> (remargs (args:get-args args '("-vpatt") '("-full") args:arg-hash 0)) ;; ==> (db (datashare:open-db configdat)) ;; ==> (versions (datashare:get-versions-for-area db (car args) version-patt: (args:get-arg "-vpatt")))) ;; ==> ;; (print "area-name=" area-name " args=" args " *args-hash*=" (hash-table->alist *args-hash*)) ;; ==> (map (lambda (x) ;; ==> (if (args:get-arg "-full") ;; ==> (format #t ;; ==> "~10a~10a~4a~27a~30a\n" ;; ==> (vector-ref x 0) ;; ==> (vector-ref x 1) ;; ==> (vector-ref x 2) ;; ==> (conc "\"" (time->string (seconds->local-time (vector-ref x 3))) "\"") ;; ==> (conc "\"" (vector-ref x 4) "\"")) ;; ==> (print (vector-ref x 0)))) ;; ==> versions) ;; ==> (sqlite3:finalize! db))))) ;; ==> ;; ==> ;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION! ;; ==> (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.datasharerc"))) ;; ==> (if (common:file-exists? debugcontrolf) ;; ==> (load debugcontrolf))) ;; ==> ;; ==> (define (main) ;; ==> (let* ((args (argv)) ;; ==> (prog (car args)) ;; ==> (rema (cdr args)) ;; ==> (exe-name (pathname-file (car (argv)))) ;; ==> (exe-dir (or (pathname-directory prog) ;; ==> (datashare:find exe-name (string-split (get-environment-variable "PATH") ":")))) ;; ==> (configdat (datashare:load-config exe-dir exe-name))) ;; ==> (cond ;; ==> ;; one-word commands ;; ==> ((eq? (length rema) 1) ;; ==> (case (string->symbol (car rema)) ;; ==> ((help -h -help --h --help) ;; ==> (print datashare:help)) ;; ==> ((list-areas) ;; ==> (map print (datashare:get-areas configdat))) ;; ==> (else ;; ==> (print "ERROR: Unrecognised command. Try \"datashare help\"")))) ;; ==> ;; multi-word commands ;; ==> ((null? rema)(datashare:gui configdat)) ;; ==> ((>= (length rema) 2) ;; ==> (apply datashare:process-action configdat (car rema)(cdr rema))) ;; ==> (else (print "ERROR: Unrecognised command. Try \"datashare help\""))))) ;; ==> ;; ==> (main) |
Modified db.scm from [999bf6a3c9] to [4d25c1f0fd].
︙ | ︙ | |||
20 21 22 23 24 25 26 | ;;====================================================================== ;; Database access ;;====================================================================== ;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc | > | < < < | | | > | | > > > > > > > > > > > > > > > > > > > > > > > > > > < < < | | < < | < < < < < < < < < | < < < < | | > > > > < < < < < < < < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > | > | | > | > > | | | | | | > | | | > | < < < < > > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < | | < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | 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 | ;;====================================================================== ;; Database access ;;====================================================================== ;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc (declare (unit db)) (declare (uses common)) (declare (uses debugprint)) (declare (uses dbmod)) (declare (uses dbfile)) (declare (uses keys)) (declare (uses ods)) (declare (uses mt)) (declare (uses commonmod)) (declare (uses mtargs)) (declare (uses rmtmod)) (import commonmod (prefix mtargs args:)) (use (srfi 18) extras ;; tcp stack (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest (prefix base64 base64:) format dot-locking z3 typed-records matchable files) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") (include "run_records.scm") (define *number-of-writes* 0) (define *number-non-write-queries* 0) (import debugprint) (import dbfile) (import dbmod) (import rmtmod) ;; record for keeping state,status and count for doing roll-ups in ;; iterated tests ;; (defstruct dbr:counts (state #f) (status #f) (count 0)) ;; (define (db:with-db dbstruct run-id r/w proc . params) ;; (case (rmt:transport-mode) ;; ((http)(dbfile:with-db dbstruct run-id r/w proc params)) ;; ((tcp) (dbmod:with-db dbstruct run-id r/w proc params)) ;; ((nfs) (dbmod:with-db dbstruct run-id r/w proc params)) ;; (else (assert #f "FATAL: db:with-db called with non-existant transport mode")))) ;;====================================================================== ;; 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)))) ;;====================================================================== ;; 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? ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn) ;; (print "err-status: " err-status) (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port)))) ;; convert to -inline ;; (define (db:first-result-default db stmt default . params) (handle-exceptions exn (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn) (if (eq? err-status 'done) default (begin (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) (print-call-chain (current-error-port)) default))) (apply sqlite3:first-result db stmt params))) (define (db:setup) (assert *toppath* "FATAL: db:setup called before launch:setup has been run.") (let* ((tmpdir (common:make-tmpdir-name *toppath* ""))) (if (not *dbstruct-dbs*) (dbfile:setup (conc *toppath* "/.mtdb") tmpdir) *dbstruct-dbs*))) ;; moved from dbfile ;; ;; ADD run-id SUPPORT ;; (define (db:create-all-triggers dbstruct) (db:with-db dbstruct #f #t (lambda (dbdat 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 #t (lambda (dbdat db) (db:drop-triggers db)))) (define (db:have-incompletes? dbstruct run-id ovr-deadtime) (let* ((incompleted '()) (oldlaunched '()) (toplevels '()) ;; (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) (deadtime (or ovr-deadtime 72000))) ;; twenty hours (db:with-db dbstruct run-id #f (lambda (dbdat db) ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes ;; ;; HOWEVER: this code in run:test seems to work fine ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) ;; (db:test-get-run_duration testdat))) ;; 600) ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? (begin (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))) ;; (print-info "Found old toplevel test in RUNNING state, test-id=" test-id)) (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))) (db:get-cache-stmth dbdat db "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');") run-id deadtime) ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config ;; ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched)))) (db:get-cache-stmth dbdat db "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');") run-id) ;; (print-info "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))))) ;; looks up subdb and returns it, if not found then set up ;; and then return it. ;; #;(define (db:get-db dbstruct run-id) (let* ((res (dbfile:get-subdb dbstruct run-id))) (if res res (let* ((newsubdb (make-dbr:subdb))) (dbfile:set-subdb dbstruct run-id newsubdb) (db:open-db dbstruct run-id areapath: (dbr:dbstruct-areapath dbstruct) do-sync: #t) newsubdb)))) ;; Get/open a database ;; if run-id => get run specific db ;; if #f => get main db ;; if run-id is a string treat it as a filename ;; if db already open - return cachedb ;; if db not open, open cachedb, rundb and sync then return cachedb ;; inuse gets set automatically for rundb's ;; ;; (define db:get-db db:get-subdb) ;; (define (db:get-db subdb #;dbstruct run-id) ;; RENAME TO db:get-dbh ;; ;; (let* ((subdb (dbfile:get-subdb dbstruct run-id))) ;; (if (stack? (dbr:subdb-dbstack subdb)) ;; (if (stack-empty? (dbr:subdb-dbstack subdb)) ;; (let* ((dbname (db:run-id->dbname run-id)) ;; (newdb (db:open-megatest-db path: (db:dbfile-path) ;; name: dbname))) ;; ;; NOTE: pushing on the stack only happens AFTER the handle has been used ;; ;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb) ;; newdb) ;; (stack-pop! (dbr:subdb-dbstack subdb))) ;; (db:open-db subdb run-id))) ;; ) #;(define (db:get-db dbstruct run-id) (let* ((subdb (dbfile:get-subdb dbstruct run-id)) (dbdat (dbfile:get-dbdat dbstruct run-id))) (if (dbr:dbdat? dbdat) dbdat (dbfile:open-db *dbstruct-dbs* #f db:initialize-main-db) ) ) ) (define-inline (db:generic-error-printout exn . message) (print-call-chain (current-error-port)) (apply debug:print-error 0 *default-log-port* message) (debug:print-error 0 *default-log-port* " params: " params ", error: " ((condition-property-accessor 'exn 'message) exn) ", arguments: " ((condition-property-accessor 'exn 'arguments) exn) ", location: " ((condition-property-accessor 'exn 'location) exn) )) (define (db:set-sync db) (let ((syncprag (configf:lookup *configdat* "setup" "sychronous"))) (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 0) ";")))) (define (db:get-last-update-time db) (let ((last-update-time #f)) (sqlite3:for-each-row (lambda (lup) (set! last-update-time lup)) db "select max(lup) from ( select max(last_update) as lup from tests union select max(last_update) as lup from runs);") last-update-time)) ;; Open the classic megatest.db file (defaults to open in toppath) ;; ;; NOTE: returns a dbdat not a dbstruct! ;; (define (db:open-megatest-db dbpath) (let* ((dbexists (file-exists? dbpath)) (db (db:lock-create-open dbpath (lambda (db) (db:initialize-main-db db)))) (write-access (file-write-access? dbpath))) (debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) ;; (cons db dbpath))) (make-dbr:dbdat dbfile: dbpath dbh: db read-only: (not write-access)))) ;; use bunch of Unix commands to try to break the lock and recreate the db ;; (define (db:move-and-recreate-db dbdat) (let* ((dbpath (dbr:dbdat-dbfile dbdat)) (dbdir (pathname-directory dbpath)) (fname (pathname-strip-directory dbpath)) (fnamejnl (conc fname "-journal")) (tmpname (conc fname "." (current-process-id))) (tmpjnl (conc fnamejnl "." (current-process-id)))) (debug:print-error 0 *default-log-port* "" fname " appears corrupted. Making backup \"old/" fname "\"") (system (conc "cd " dbdir ";mkdir -p old;cat " fname " > old/" tmpname)) (system (conc "rm -f " dbpath)) (if (common:file-exists? fnamejnl) (begin (debug:print-error 0 *default-log-port* "" fnamejnl " found, moving it to old dir as " tmpjnl) (system (conc "cd " dbdir ";mkdir -p old;cat " fnamejnl " > old/" tmpjnl)) (system (conc "rm -f " dbdir "/" fnamejnl)))) ;; attempt to recreate database (system (conc "cd " dbdir ";sqlite3 old/" tmpname " .dump | sqlite3 " fname)))) ;; return #f to indicate the dbdat should be closed/reopened ;; else return dbdat ;; (define (db:repair-db dbdat #!key (numtries 1)) (let* ((dbpath (dbr:dbdat-dbfile dbdat)) (dbdir (pathname-directory dbpath)) (fname (pathname-strip-directory dbpath))) (debug:print-info 0 *default-log-port* "Checking db " dbpath " for errors.") (cond ((not (file-write-access? dbdir)) (debug:print 0 *default-log-port* "WARNING: can't write to " dbdir ", can't fix " fname) #f) ;; handle special cases, megatest.db and monitor.db ;; ;; NOPE: apply this same approach to all db files ;; (else ;; ((equal? fname "megatest.db") ;; this file can be regenerated if needed (handle-exceptions exn (begin (debug:print 0 *default-debug-port* "Problems trying to repair the db, exn=" exn) ;; (db:move-and-recreate-db dbdat) (if (> numtries 0) (db:repair-db dbdat numtries: (- numtries 1)) #f) (debug:print 0 *default-log-port* "FATAL: file " dbpath " was found corrupted, an attempt to fix has been made but you must start over.") (debug:print 0 *default-log-port* " check the following:\n" |
︙ | ︙ | |||
673 674 675 676 677 678 679 | (sqlite3:execute "DELETE FROM servers WHERE state LIKE 'defunct%';")) (else (sqlite3:execute db "vacuum;"))) (sqlite3:finalize! db) #t)))))) | < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 | (sqlite3:execute "DELETE FROM servers WHERE state LIKE 'defunct%';")) (else (sqlite3:execute db "vacuum;"))) (sqlite3:finalize! db) #t)))))) (define (db:adj-target db) (let ((fields (configf:get-section *configdat* "fields")) (field-num 0)) ;; because we will be refreshing the keys table it is best to clear it here (sqlite3:execute db "DELETE FROM keys;") (for-each |
︙ | ︙ | |||
1004 1005 1006 1007 1008 1009 1010 | ;; return the target db handle so it can be used ;; (define (db:cache-for-read-only source target #!key (use-last-update #f)) (if (and (hash-table-ref/default *global-db-store* target #f) (>= (file-modification-time target)(file-modification-time source))) (hash-table-ref *global-db-store* target) (let* ((toppath (launch:setup)) | > | > | | | > > > > > > > > > > | | < | | | > | > | | > > > > | > > > > > > > > > > | | > > > | > > > > > > > > > > > > > > > > > > > > | > > | > > | | > | | | | < > > > | > > > > > | | > | < > > | > > > > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < < | < < < | | > > > > > > | > | | < | | > > > | | | > > > > > > | < | | < | > > | > | < < | < | < < > > > > > > > > > > > | < > > > > > | < < < < | < < | < < < < > | | | > | > | | < < < < < < < | > > > > | > > > > > | > > | > > > > | | | | | > > > > | 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 | ;; return the target db handle so it can be used ;; (define (db:cache-for-read-only source target #!key (use-last-update #f)) (if (and (hash-table-ref/default *global-db-store* target #f) (>= (file-modification-time target)(file-modification-time source))) (hash-table-ref *global-db-store* target) (let* ((toppath (launch:setup)) (targ-db-last-mod (db:get-sqlite3-mod-time target)) ;; (if (common:file-exists? target) ;; BUG: This needs to include wal mode stuff .shm etc. ;; (file-modification-time target) ;; 0)) (cache-db (or (hash-table-ref/default *global-db-store* target #f) (db:open-megatest-db path: target))) (source-db (db:open-megatest-db path: source)) (curr-time (current-seconds)) (res '()) (last-update (if use-last-update (cons "last_update" targ-db-last-mod) #f))) (db:sync-tables (db:sync-main-list source-db) last-update source-db cache-db) (db:sync-tables db:sync-tests-only last-update source-db cache-db) (hash-table-set! *global-db-store* target cache-db) cache-db))) (define (db:get-sqlite3-mod-time fname) (let* ((wal-file (conc fname "-wal")) (shm-file (conc fname "-shm")) (get-mtime (lambda (f) (if (and (file-exists? f) (file-read-access? f)) (file-modification-time f) 0)))) (max (get-mtime fname) (get-mtime wal-file) (get-mtime shm-file)))) ;; (define (db:all-db-sync dbstruct) ;; (let* ((dbdat (db:open-db dbstruct #f db:initialize-main-db)) ;; (data-synced 0) ;; count of changed records ;; (tmp-area (common:make-tmpdir-name *toppath*)) ;; (dbfiles (glob (conc tmp-area"/.mtdb/*.db"))) ;; (sync-durations (make-hash-table)) ;; (no-sync-db (db:open-no-sync-db))) ;; (for-each ;; (lambda (file) ;; tmp db file ;; (debug:print-info 3 *default-log-port* "file: " file) ;; (let* ((fname (conc (pathname-file file) ".db")) ;; fname is tmp db file ;; (wal-file (conc fname "-wal")) ;; (shm-file (conc fname "-shm")) ;; (fulln (conc *toppath*"/,mtdb/"fname)) ;; fulln is nfs db name ;; (wal-time (if (file-exists? wal-file) ;; (file-modification-time wal-file) ;; 0)) ;; (shm-time (if (file-exists? shm-file) ;; (file-modification-time shm-file) ;; 0)) ;; (time1 (db:get-sqlite3-mod-time file)) ;; ;; (if (file-exists? file) ;; time1 is the max itime of the tmp db, -wal and -shm files. ;; ;; (max (file-modification-time file) wal-time shm-time) ;; ;; (begin ;; ;; (debug:print-info 2 *default-log-port* "Sync - I do not see file "file) ;; ;; 1))) ;; (time2 (db:get-sqlite3-mod-time fulln)) ;; ;; (if (file-exists? fulln) ;; time2 is nfs file time ;; ;; (file-modification-time fulln) ;; ;; (begin ;; ;; (debug:print-info 2 *default-log-port* "Sync - I do not see file "fulln) ;; ;; 0))) ;; (changed (> (- time1 time2) (+ (random 5) 1))) ;; it has been at some few seconds since last synced ;; (changed10 (> (- time1 time2) 10)) ;; it has been at least ten seconds since sync'd ;; (jfile-exists (file-exists? (conc file"-journal"))) ;; i.e. are we busy? ;; (do-cp (cond ;; ((not (file-exists? fulln)) ;; shouldn't happen, but this might recover ;; (cons #t (conc "File "fulln" not found! Copying "fname" to "fulln))) ;; ((and (not jfile-exists) changed) ;; (cons #t "not busy, changed")) ;; not busy and changed ;; ((and jfile-exists changed10) ;; (cons #t "busy but not synced in a while")) ;; busy but not sync'd in over 10 seconds ;; ((and changed *time-to-exit*) ;; (cons #t "Time to exit, forced final sync")) ;; last sync ;; (else ;; (cons #f "No sync needed"))))) ;; (if (car do-cp) ;; (let* ((start-time (current-milliseconds)) ;; (fname (pathname-file file)) ;; (runid (if (string= fname "main") #f (string->number fname)))) ;; (debug:print-info 3 *default-log-port* "db:all-db-sync: fname: " ;; fname", delta: " (- time1 time2) " seconds, reason: "(cdr do-cp)) ;; (db:lock-and-delta-sync no-sync-db dbstruct fname runid (db:get-keys dbstruct) db:initialize-main-db) ;; (hash-table-set! sync-durations (conc fname".db") ;; (- (current-milliseconds) start-time))) ;; (debug:print-info 3 *default-log-port* "skipping sync. " file " is up to date") ;; ))) ;; dbfiles) ;; ;; WHY does the dbdat need to be added back? ;; (if dbdat (dbfile:add-dbdat dbstruct #f dbdat)) ;; ) ;; #t) (define (db:kill-servers) (let* ((tl (launch:setup)) ;; need this to initialize *toppath* (servdir (conc *toppath* "/.servinfo")) (servfiles (glob (conc servdir "/*:*.db"))) (fmtstr "~10a~22a~10a~25a~25a~8a\n") (dbfiles (append (glob (conc *toppath* "/.mtdb/main.db")) (glob (conc *toppath* "/.mtdb/?.db"))(glob (conc *toppath* "/.mtdb/??.db")))) (ttdat (make-tt areapath: *toppath*)) ) (format #t fmtstr "DB" "host:port" "PID" "age" "last mod" "state") (for-each (lambda (dbfile) (let* ( (dbfname (conc (pathname-file dbfile) ".db")) (sfiles (tt:find-server *toppath* dbfname)) ) (for-each (lambda (sfile) (let ( (sinfos (tt:get-server-info-sorted ttdat dbfname)) ) (for-each (lambda (sinfo) (let* ( (db (list-ref sinfo 5)) (pid (list-ref sinfo 4)) (host (list-ref sinfo 0)) (port (list-ref sinfo 1)) (server-id (list-ref sinfo 3)) (age (seconds->hr-min-sec (- (current-seconds) (list-ref sinfo 2)))) (last-mod (seconds->string (list-ref sinfo 2))) (killed (system (conc "ssh " host " kill " pid " > /dev/null"))) (dummy2 (sleep 1)) (state (if (> (system (conc "ssh " host " ps " pid " > /dev/null")) 0) "dead" "alive")) ) (format #t fmtstr db (conc host ":" port) pid age last-mod state) (system (conc "rm " sfile)) ) ) sinfos ) ) ) sfiles ) ) ) dbfiles ) ;; remove this db, because otherwise metadata contains records for old servers, and this causes a problem with db:no-sync-get-lock-with-id. (if (file-exists? (conc *toppath* "/.mtdb/no-sync.db")) (delete-file (conc *toppath* "/.mtdb/no-sync.db")) ) ) ) ;; options: ;; ;; 'killservers - kills all servers ;; 'dejunk - removes junk records ;; 'adj-testids - move test-ids into correct ranges ;; 'old2new - sync megatest.db to /tmp/.../megatest.db and /tmp/.../megatest_ref.db ;; 'new2old - sync /tmp/.../megatest.db to megatest.db and /tmp/.../megatest_ref.db (and update data_synced) ;; 'closeall - close all opened dbs ;; 'schema - attempt to apply schema changes ;; run-ids: '(1 2 3 ...) or #f (for all) ;; (define (db:multi-db-sync dbstruct . options) (let* (;; (dbdat (db:open-db dbstruct #f dbfile:db-init-proc)) (data-synced 0) ;; count of changed records (tmp-area (common:make-tmpdir-name *toppath* "")) (old2new (member 'old2new options)) (dejunk (member 'dejunk options)) (killservers (member 'killservers options)) (src-area (if old2new *toppath* tmp-area)) (dest-area (if old2new tmp-area (conc *toppath* "/.mtdb"))) (dbfiles (if old2new (glob (conc *toppath* "/.mtdb/*.db")) (glob (conc tmp-area "/*.db")))) (keys (db:get-keys dbstruct)) (sync-durations (make-hash-table))) ;; kill servers ;; (if killservers (db:kill-servers)) (if (not dbfiles) (debug:print-error 0 *default-log-port* "no dbfiles found in " (conc *toppath* "/.mtdb")) (for-each (lambda (srcfile) (debug:print-info 3 *default-log-port* "file: " srcfile) (let* ((fname (conc (pathname-file srcfile) ".db")) (basename (pathname-file srcfile)) (run-id (if (string= basename "main") #f (string->number basename))) (destfile (conc dest-area "/" fname)) (dest-directory dest-area) (time1 (file-modification-time srcfile)) (time2 (if (file-exists? destfile) (begin (debug:print-info 2 *default-log-port* "destfile " destfile " exists") (file-modification-time destfile)) (begin (debug:print-info 0 *default-log-port* "Sync - I do not see file " destfile) 0))) (changed ( < (- time2 time1) 6.0)) ;; dest db not updated within last 6 seconds (do-cp (cond ((not (file-exists? destfile)) ;; shouldn't happen, but this might recover (debug:print-info 2 *default-log-port* "File " destfile " not found. Copying "srcfile" to "destfile) ;; TODO: Need to fix this for WAL mod. Can't just copy. (system (conc "/bin/mkdir -p " dest-directory)) (system (conc "/bin/cp " srcfile " " destfile)) #t) (changed ;; (and changed #t) ((and changed *time-to-exit*) ;; last sync #t) (else #f)))) (if (or dejunk do-cp) (let* ((start-time (current-milliseconds)) (subdb (or (dbfile:get-subdb dbstruct run-id) (dbfile:init-subdb dbstruct run-id dbfile:db-init-proc))) (dbdat (or (dbfile:get-dbdat dbstruct run-id) (dbfile:open-db dbstruct run-id dbfile:db-init-proc))) (mtdb (dbr:subdb-mtdbdat subdb)) ;; ;; BUG: -mrw- I think this next line is wrong. run-id should be the path to .mtdb/<runid>.db ;; (tmpdb (dbfile:open-db dbstruct run-id dbfile:db-init-proc))) (if dejunk (begin (debug:print 0 *default-log-port* "Cleaning tmp DB") (db:clean-up run-id tmpdb) (debug:print 0 *default-log-port* "Cleaning nfs DB") (db:clean-up run-id mtdb) ) ) (debug:print-info 2 *default-log-port* "delta syncing file: " srcfile ", time diff: " (- time1 time2) " seconds") (if old2new (begin (db:sync-tables (db:sync-all-tables-list (db:get-keys dbstruct)) #f mtdb tmpdb)) (begin (db:sync-tables (db:sync-all-tables-list (db:get-keys dbstruct)) #f tmpdb mtdb))) (hash-table-set! sync-durations (conc srcfile ".db") (- (current-milliseconds) start-time))) (debug:print-info 2 *default-log-port* "skipping delta sync. " srcfile " is up to date")))) dbfiles)) data-synced)) ;; Sync all changed db's ;; (define (db:tmp->megatest.db-sync dbstruct run-id last-update) (let* ((subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct))) (res '())) (for-each (lambda (subdb) (let* ((mtdb (dbr:subdb-mtdb subdb)) (tmpdb (db:get-subdb dbstruct run-id)) (refndb (dbr:subdb-refndb subdb)) (newres (db:sync-tables (db:sync-all-tables-list (db:get-keys dbstruct)) last-update tmpdb refndb mtdb))) ;; (stack-push! (dbr:subdb-dbstack subdb) tmpdb) ;; BUG: verify this is really needed (dbfile:add-dbdat dbstruct run-id tmpdb) (set! res (cons newres res)))) subdbs) res)) ;;;; run-ids ;; if #f use *db-local-sync* : or 'local-sync-flags ;; if #t use timestamps : or 'timestamps ;; ;; NB// no-sync-db is the db handle, not a flag! |
︙ | ︙ | |||
1171 1172 1173 1174 1175 1176 1177 | (debug:print-info 3 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id)) (if (common:low-noise-print 30 "sync new to old") (if sync-needed (debug:print-info 0 *default-log-port* "Sync of " res " records from newdb to olddb completed in " sync-time " seconds pid="(current-process-id)) (debug:print-info 0 *default-log-port* "No sync needed, last updated " (- start-time last-update) " seconds ago"))) res)) | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | > > > > > > > > > > | | | 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 | (debug:print-info 3 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id)) (if (common:low-noise-print 30 "sync new to old") (if sync-needed (debug:print-info 0 *default-log-port* "Sync of " res " records from newdb to olddb completed in " sync-time " seconds pid="(current-process-id)) (debug:print-info 0 *default-log-port* "No sync needed, last updated " (- start-time last-update) " seconds ago"))) res)) (define (db:initialize-main-db db) (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)) (keystr (keys->keystr keys)) (fieldstr (keys:make-key/field-string configdat)) #;(db (dbr:dbdat-dbh dbdat))) (for-each (lambda (key) (let ((keyn key)) (if (member (string-downcase keyn) (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour")) (begin (debug:print 0 *default-log-port* "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table, you must remove your megatest.db and <linktree>/.db before trying again.") (exit 1))))) keys) (sqlite3:with-transaction db (lambda () ;; handle-exceptions ;; exn ;; (begin ;; (debug:print 0 "ERROR: Failed to create tables. Look at your [fields] section, should be: fieldname TEXT DEFAULT 'yourdefault'") ;; (exit)) (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));") (for-each (lambda (key) (let* ((fieldname #f) (fieldtype #f)) (sqlite3:for-each-row (lambda (fn ft) (set! fieldname fn) (set! fieldtype ft)) db "SELECT fieldname,fieldtype FROM keys WHERE fieldname=?" key) (if (not fieldname) (sqlite3:execute db "INSERT INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT")))) keys) (sqlite3:execute db (conc "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, \n " fieldstr (if havekeys "," "") " runname TEXT DEFAULT 'norun', contour TEXT DEFAULT '', state TEXT DEFAULT '', status TEXT DEFAULT '', |
︙ | ︙ | |||
1428 1429 1430 1431 1432 1433 1434 | ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, CONSTRAINT metadat_constraint UNIQUE (var));") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") ;; Must do this *after* running patch db !! No more. ;; cannot use db:set-var since it will deadlock, hardwire the code here | > > > > > > > > > > | | 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 | ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, CONSTRAINT metadat_constraint UNIQUE (var));") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") ;; Must do this *after* running patch db !! No more. ;; cannot use db:set-var since it will deadlock, hardwire the code here (let* ((prev-version #f) (curr-version (common:version-signature))) (sqlite3:for-each-row (lambda (ver) (set! prev-version ver)) db "SELECT val FROM metadat WHERE var='MEGATEST_VERSION';") (if prev-version (if (not (equal? prev-version curr-version)) (sqlite3:execute db "UPDATE metadat SET val=? WHERE var=?;" curr-version "MEGATEST_VERSION")) (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" curr-version) )) (debug:print-info 11 *default-log-port* "db:initialize END") ;; )))) ;;====================================================================== ;; R U N S P E C I F I C D B ;;====================================================================== ;; (define (db:initialize-run-id-db db) |
︙ | ︙ | |||
1487 1488 1489 1490 1491 1492 1493 | 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));") | | | 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 | 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 test_steps (test_id, stepname, state);") ;; 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;") |
︙ | ︙ | |||
1523 1524 1525 1526 1527 1528 1529 | (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, | | > | > | | | 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 | (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, last_update INTEGER DEFAULT (strftime('%s','now')));") (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, last_update INTEGER DEFAULT (strftime('%s','now')));"))) (db:create-triggers db) db)) ;; ) ;;====================================================================== ;; A R C H I V E S ;;====================================================================== ;; dneeded is minimum space needed, scan for existing archives that ;; are on disks with adequate space and already have this test/itempath ;; archived ;; (define (db:archive-get-allocations dbstruct testname itempath dneeded) (let* ((dbdat (db:get-subdb dbstruct #f)) ;; archive tables are in main.db (db (dbr:dbdat-dbh dbdat)) (res '()) (blocks '())) ;; a block is an archive chunck that can be added too if there is space (sqlite3:for-each-row (lambda (id archive-disk-id disk-path last-du last-du-time) (set! res (cons (vector id archive-disk-id disk-path last-du last-du-time) res))) db "SELECT b.id,b.archive_disk_id,b.disk_path,b.last_du,b.last_du_time FROM archive_blocks AS b |
︙ | ︙ | |||
1569 1570 1571 1572 1573 1574 1575 | db (conc "SELECT d.id,d.archive_area_name,disk_path,last_df,last_df_time FROM archive_disks AS d INNER JOIN archive_blocks AS b ON d.id=b.archive_disk_id WHERE b.id IN (" (string-intersperse (map conc res) ",") ") AND last_df > ?;") dneeded)) | > | | | | | | | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < | < < < < | < < < < < < < < < < < < < < < < < < < | | | | | < < < < < < < < < < < < < < > | | | | | | | | | < | | | | | | < | < < < | < | < < < < < < < < < < < < | < < < | | | | | | | | | | < < < | | > | | | < | | < < < < | < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < | | > > > > > > > > > > > > > > > > > > > > > > > > > | < | | > < < < | < < < < < < < < < | < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | > | < < < < < < < < < | | | > > > | | | < | | 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 | db (conc "SELECT d.id,d.archive_area_name,disk_path,last_df,last_df_time FROM archive_disks AS d INNER JOIN archive_blocks AS b ON d.id=b.archive_disk_id WHERE b.id IN (" (string-intersperse (map conc res) ",") ") AND last_df > ?;") dneeded)) ;; BUG: Verfify this is really needed (dbfile:add-dbdat dbstruct #f dbdat) blocks)) ;; returns id of the record, register a disk allocated to archiving and record it's last known ;; available space ;; (define (db:archive-register-disk dbstruct bdisk-name bdisk-path df) (let* ((dbdat (db:get-subdb dbstruct #f)) ;; archive tables are in main.db (db (dbr:dbdat-dbh dbdat)) (res #f)) (sqlite3:for-each-row (lambda (id) (set! res id)) db "SELECT id FROM archive_disks WHERE archive_area_name=? AND disk_path=?;" bdisk-name bdisk-path) (if res ;; record exists, update df and return id (begin (sqlite3:execute db "UPDATE archive_disks SET last_df=?,last_df_time=(strftime('%s','now')) WHERE archive_area_name=? AND disk_path=?;" df bdisk-name bdisk-path) (dbfile:add-dbdat dbstruct #f dbdat) res) (begin (sqlite3:execute db "INSERT OR REPLACE INTO archive_disks (archive_area_name,disk_path,last_df) VALUES (?,?,?);" bdisk-name bdisk-path df) (dbfile:add-dbdat dbstruct #f dbdat) (db:archive-register-disk dbstruct bdisk-name bdisk-path df))))) ;; record an archive path created on a given archive disk (identified by it's bdisk-id) ;; if path starts with / then it is full, otherwise it is relative to the archive disk ;; preference is to store the relative path. ;; (define (db:archive-register-block-name dbstruct bdisk-id archive-path #!key (du #f)) (let* ((dbdat (db:get-subdb dbstruct #f)) ;; archive tables are in main.db (db (dbr:dbdat-dbh dbdat)) (res #f)) ;; first look to see if this path is already registered (sqlite3:for-each-row (lambda (id) (set! res id)) db "SELECT id FROM archive_blocks WHERE archive_disk_id=? AND disk_path=?;" bdisk-id archive-path) (if res ;; record exists, update du if applicable and return res (if du (sqlite3:execute db "UPDATE archive_blocks SET last_du=?,last_du_time=(strftime('%s','now')) WHERE archive_disk_id=? AND disk_path=?;" bdisk-id archive-path du)) (begin (sqlite3:execute db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du) VALUES (?,?,?);" bdisk-id archive-path (or du 0)) (set! res (db:archive-register-block-name dbstruct bdisk-id archive-path du: du)))) (dbfile:add-dbdat dbstruct #f dbdat) res)) ;; The "archived" field in tests is overloaded; 0 = not archived, > 0 archived in block with given id ;; (define (db:test-set-archive-block-id dbstruct run-id test-id archive-block-id) (db:with-db dbstruct run-id #t (lambda (dbdat db) (sqlite3:execute db "UPDATE tests SET archived=? WHERE id=?;" archive-block-id test-id)))) ;; Look up the archive block info given a block-id ;; (define (db:test-get-archive-block-info dbstruct archive-block-id) (db:with-db dbstruct #f #f (lambda (dbdat db) (let ((res #f)) (sqlite3:for-each-row ;; 0 1 2 3 4 5 (lambda (id archive-disk-id disk-path last-du last-du-time creation-time) (set! res (vector id archive-disk-id disk-path last-du last-du-time creation-time))) db "SELECT id,archive_disk_id,disk_path,last_du,last_du_time,creation_time FROM archive_blocks WHERE id=?;" archive-block-id) res)))) ;; (define (db:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey) ;; (let* ((dbdat (db:get-subdb dbstruct #f)) ;; archive tables are in main.db ;; (db (dbr:dbdat-dbh dbdat)) ;; (res '()) ;; (blocks '())) ;; a block is an archive chunck that can be added too if there is space ;; (sqlite3:for-each-row #f) ;;====================================================================== ;; D B U T I L S ;;====================================================================== ;;====================================================================== ;; M A I N T E N A N C E ;;====================================================================== ;; (define (db:have-incompletes? dbstruct run-id ovr-deadtime) ;; (let* ((incompleted '()) ;; (oldlaunched '()) ;; (toplevels '()) ;; (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) ;; (deadtime (if (and deadtime-str ;; (string->number deadtime-str)) ;; (string->number deadtime-str) ;; 72000))) ;; twenty hours ;; (db:with-db ;; dbstruct run-id #f ;; (lambda (dbdat db) ;; (if (number? ovr-deadtime)(set! deadtime ovr-deadtime)) ;; ;; ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes ;; ;; ;; ;; HOWEVER: this code in run:test seems to work fine ;; ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) ;; ;; (db:test-get-run_duration testdat))) ;; ;; 600) ;; ;; (db:delay-if-busy dbdat) ;; (sqlite3:for-each-row ;; (lambda (test-id run-dir uname testname item-path) ;; (if (and (equal? uname "n/a") ;; (equal? item-path "")) ;; this is a toplevel test ;; ;; what to do with toplevel? call rollup? ;; (begin ;; (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) ;; (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id)) ;; (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))) ;; (db:get-cache-stmth dbdat db ;; "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');") ;; run-id deadtime) ;; ;; ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config ;; ;; ;; ;; (db:delay-if-busy dbdat) ;; (sqlite3:for-each-row ;; (lambda (test-id run-dir uname testname item-path) ;; (if (and (equal? uname "n/a") ;; (equal? item-path "")) ;; this is a toplevel test ;; ;; what to do with toplevel? call rollup? ;; (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) ;; (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched)))) ;; (db:get-cache-stmth dbdat db ;; "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');") ;; run-id) ;; ;; (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))))) ;; BUG: Probably broken - does not explicitly use run-id in the query ;; (define (db:top-test-set-per-pf-counts dbstruct run-id test-name) (db:general-call dbstruct run-id 'top-test-set-per-pf-counts (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name))) ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: ;; ;; 1. Look at test records either deleted or part of deleted run: ;; a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown' ;; b. If test dir gone, delete the test record ;; 2. Look at run records ;; a. If have tests that are not deleted, set state='unknown' ;; b. .... ;; (define (db:clean-up run-id dbdat) (if run-id (begin (debug:print 0 *default-log-port* "Cleaning run DB " run-id) (db:clean-up-rundb dbdat run-id) ) (begin (debug:print 0 *default-log-port* "Cleaning main DB ") (db:clean-up-maindb dbdat) ) ) ) ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: ;; ;; 1. Look at test records either deleted or part of deleted run: ;; a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown' ;; b. If test dir gone, delete the test record ;; 2. Look at run records ;; a. If have tests that are not deleted, set state='unknown' ;; b. .... ;; (define (db:clean-up-rundb dbdat run-id) ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") (let* ((db (dbr:dbdat-dbh dbdat)) (test-count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests);")) (step-count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM test_steps);")) (statements (map (lambda (stmt) (sqlite3:prepare db stmt)) (list "DELETE FROM tests WHERE state='DELETED';" "DELETE FROM test_steps WHERE status = 'DELETED';" "DELETE FROM tests WHERE run_id IN (SELECT id FROM runs WHERE state = 'deleted');" )))) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Test records count before clean: " tot)) test-count-stmt) (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Test_step records count before clean: " tot)) step-count-stmt) (map sqlite3:execute statements) (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Test records count after clean: " tot)) test-count-stmt) (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Test_step records count after clean: " tot)) step-count-stmt))) (map sqlite3:finalize! statements) (sqlite3:finalize! test-count-stmt) (sqlite3:finalize! step-count-stmt) (sqlite3:execute db "VACUUM;"))) ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: ;; ;; 1. Look at test records either deleted or part of deleted run: ;; a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown' ;; b. If test dir gone, delete the test record ;; 2. Look at run records ;; a. If have tests that are not deleted, set state='unknown' ;; b. .... ;; (define (db:clean-up-maindb dbdat) ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") (let* ((db (dbr:dbdat-dbh dbdat)) (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM runs);")) (statements (map (lambda (stmt) (sqlite3:prepare db stmt)) (list ;; delete all tests that belong to runs that are 'deleted' ;; (conc "DELETE FROM tests WHERE run_id NOT IN (" (string-intersperse (map conc valid-runs) ",") ");") |
︙ | ︙ | |||
2079 2080 2081 2082 2083 2084 2085 | db "SELECT id FROM runs WHERE state='deleted';") ;; (db:delay-if-busy dbdat) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tot) | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > > > > > > > > | < | < | < | | | | < < < < < | > > | > > | 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 | db "SELECT id FROM runs WHERE state='deleted';") ;; (db:delay-if-busy dbdat) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Run records count before clean: " tot)) count-stmt) (map sqlite3:execute statements) (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Run records count after clean: " tot)) count-stmt))) (map sqlite3:finalize! statements) (sqlite3:finalize! count-stmt) ;; (db:find-and-mark-incomplete db) ;; (db:delay-if-busy dbdat) (sqlite3:execute db "VACUUM;") dead-runs)) ;;====================================================================== ;; no-sync.db - small bits of data to be shared between servers ;;====================================================================== ;; if we are not a server create a db handle. this is not finalized ;; so watch for problems. I'm still not clear if it is needed to manually ;; finalize sqlite3 dbs with the sqlite3 egg. ;; (define (db:no-sync-db db-in) (mutex-lock! *db-access-mutex*) (let ((res (if db-in db-in (let ((db (db:open-no-sync-db))) (set! *no-sync-db* db) db)))) (mutex-unlock! *db-access-mutex*) res)) (define (db:get-dbsync-path) (case (rmt:transport-mode) ((http)(common:make-tmpdir-name *toppath* "")) ((tcp) (conc *toppath*"/.mtdb")) ((nfs) (conc *toppath*"/.mtdb")) (else "/tmp/dunno-this-gonna-exist"))) (define (db:no-sync-add-job db-in host-type vars-list exekey cmdline) (sqlite3:execute (db:no-sync-db db-in) "INSERT INTO jobs_queue (host_type,vars,exekey,cmdline,state,event_time,last_update) VALUES (?,?,?,?,?,?,?);" host-type (with-output-to-string (lambda () (write vars-list))) |
︙ | ︙ | |||
2221 2222 2223 2224 2225 2226 2227 | ;; clean out old jobs in queue, i.e. taken and event_time > 24 hrs ago ;; (define (db:no-sync-job-records-clean db) (sqlite3:execute (db:no-sync-db db) "DELETE FROM jobs_queue WHERE state='taken' AND event_time < ?;" (- (current-seconds)(* 24 3600)))) | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | < < < | < < < < < | < < < < < > > > | | | | | | | | | | | | > > | | < < < < | | | | | | | | | | < | < < | | | 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 | ;; clean out old jobs in queue, i.e. taken and event_time > 24 hrs ago ;; (define (db:no-sync-job-records-clean db) (sqlite3:execute (db:no-sync-db db) "DELETE FROM jobs_queue WHERE state='taken' AND event_time < ?;" (- (current-seconds)(* 24 3600)))) (define (db:no-sync-get/default db-in var default) (let ((db (db:no-sync-db db-in)) (res default)) (sqlite3:for-each-row (lambda (val) (set! res val)) (db:no-sync-db db) "SELECT val FROM no_sync_metadat WHERE var=?;" var) (if res (let ((newres (if (string? res) (string->number res) #f))) (if newres newres res)) res))) ;; This is needed for api.scm (define (db:open-no-sync-db) (dbfile:open-no-sync-db (db:get-dbsync-path))) ;; why get the keys from the db? why not get from the *configdat* ;; using keys:config-get-fields? (define (db:get-keys dbstruct) (keys:config-get-fields *configdat*)) ;; extract index number given a header/data structure (define (db:get-index-by-header header field) (list-index (lambda (x)(equal? x field)) header)) ;; look up values in a header/data structure (define (db:get-value-by-header row header field) (let ((len (if (vector? row) (vector-length row) 0))) (if (or (null? header) (not row)) #f (let loop ((hed (car header)) (tal (cdr header)) (n 0)) (if (equal? hed field) (handle-exceptions exn (begin (debug:print 4 *default-log-port* "WARNING: attempt to read non-existant field, row=" row " header=" header " field=" field ", exn=" exn) #f) (if (>= n len) #f (vector-ref row n))) (if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1)))))))) ;; Accessors for the header/data structure ;; get rows and header from (define (db:get-header vec)(vector-ref vec 0)) (define (db:get-rows vec)(vector-ref vec 1)) ;;====================================================================== ;; R U N S ;;====================================================================== (define (db:get-run-times dbstruct run-patt target-patt) (let ((res `()) (qry (conc "select runname, (max(end_time)-min(event_time))/60 as runtime, target from (select runname, run_id,tests.event_time,tests.event_time+run_duration AS end_time, " (string-join (db:get-keys dbstruct) " || '/' || ") " as target from tests inner join runs on tests.run_id = runs.id where runs.runname like ? and target like ?) group by run_id ;"))) ;(print qry) (db:with-db dbstruct #f ;; this is for the main runs db #f ;; does not modify db (lambda (dbdat db) (sqlite3:for-each-row (lambda (runname runtime target ) (set! res (cons (vector runname runtime target) res))) db qry run-patt target-patt) res)))) (define (db:get-run-name-from-id dbstruct run-id) (db:with-db dbstruct #f ;; this is for the main runs db #f ;; does not modify db (lambda (dbdat db) (let ((res #f)) (sqlite3:for-each-row (lambda (runname) (set! res runname)) db "SELECT runname FROM runs WHERE id=?;" run-id) res)))) (define (db:get-run-key-val dbstruct run-id key) (db:with-db dbstruct #f #f (lambda (dbdat db) (let ((res #f)) (sqlite3:for-each-row (lambda (val) (set! res val)) db (conc "SELECT " key " FROM runs WHERE id=?;") run-id) |
︙ | ︙ | |||
2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 | (contour (or contour-in "")) ;; empty string to force no hierarcy and be backwards compatible. (comma (if (> (length keys) 0) "," "")) (andstr (if (> (length keys) 0) " AND " "")) (valslots (keys->valslots keys)) ;; ?,?,? ... (allvals (append (list runname state status user contour) (map cadr keyvals))) (qryvals (append (list runname) (map cadr keyvals))) (key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND "))) (debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) (debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run") (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and" (db:with-db | > | | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (contour (or contour-in "")) ;; empty string to force no hierarcy and be backwards compatible. (comma (if (> (length keys) 0) "," "")) (andstr (if (> (length keys) 0) " AND " "")) (valslots (keys->valslots keys)) ;; ?,?,? ... (allvals (append (list runname state status user contour) (map cadr keyvals))) (qryvals (append (list runname) (map cadr keyvals))) (key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND "))) ;; (debug:print 0 *default-log-port* "Got here 0.") (debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) (debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run") (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and" (db:with-db dbstruct #f #t (lambda (dbdat db) ;; (debug:print 0 *default-log-port* "Got here 1.") (let ((res #f)) (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time,contour" comma keystr ") VALUES (?,?,?,?,strftime('%s','now'),?" comma valslots ");") allvals) (apply sqlite3:for-each-row (lambda (id) (set! res id)) db (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");"))) qry) qryvals) (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res) res))) (begin (debug:print-error 0 *default-log-port* "Called without all necessary keys") #f)))) (define (db:get-run-id dbstruct runname target) (let ((runs (db:simple-get-runs dbstruct runname #f #f target #f))) ;; runpatt count offset target last-update (if (null? runs) #f (simple-run-id (car runs))))) ;; called with run-id=#f so will operate on main.db ;; (define (db:insert-run dbstruct run-id target runname run-meta) (let* ((keys (db:get-keys dbstruct)) (runs (db:simple-get-runs dbstruct runname #f #f target #f))) ;; runpatt count offset target last-update ;; need to insert run based on target and runname (let* ((targvals (string-split target "/")) (keystr (string-intersperse keys ",")) (key?str (string-intersperse (make-list (length targvals) "?") ",")) (qrystr (conc "INSERT INTO runs (id,runname,"keystr") VALUES (?,?,"key?str")")) (get-var (lambda (db qrystr) (let* ((res #f)) (sqlite3:for-each-row (lambda row (set res (car row))) db qrystr run-id runname) res)))) (if (null? runs) (begin (db:create-initial-run-record dbstruct run-id runname target) ) ) (let* () ;;(debug:print 0 *default-log-port* "db:insert-run: Calling db:with-db to update the run record") (debug:print 0 *default-log-port* "db:insert-run: runid = " run-id) #; (db:with-db dbstruct #f #t (lambda (dbdat db) (debug:print 0 *default-log-port* "In the lambda proc for " dbdat " " db) (for-each (lambda (keyval) (debug:print 0 *default-log-port* "In the lambda proc for " keyval) (let* ((fieldname (car keyval)) (getqry (conc "SELECT "fieldname" FROM runs WHERE id=?;")) (setqry (conc "UPDATE runs SET "fieldname"=? WHERE id=?;")) (val (cdr keyval)) (valnum (if (number? val) val (if (string? val) (string->number val) #f)))) (debug:print 0 *default-log-port* "fieldname " fieldname " val " val " valnum " valnum) (if (not (member fieldname (cons "runname" keys))) ;; don't attempt to tweak these (let* ((curr-val (get-var db getqry)) (have-it (or (equal? curr-val val) (equal? curr-val valnum)))) (debug:print 0 *default-log-port* "have-it = " have-it) (if (not have-it) (begin (debug:print 0 *default-log-port* "Do sqlite3:execute") ;; (sqlite3:execute db setqry (or valnum val) run-id) ) ) ) ) (debug:print 0 *default-log-port* "Done with update") ) (debug:print 0 *default-log-port* "next keyval") ) run-meta))) run-id)))) (define (db:create-initial-run-record dbstruct run-id runname target) (let* ((keys (db:get-keys dbstruct)) (targvals (string-split target "/")) (keystr (string-intersperse keys ",")) (key?str (string-intersperse (make-list (length targvals) "?") ",")) ;; a string with the same length as targvals, where each element is "?" and interspersed with commas. (qrystr (conc "INSERT INTO runs (id,runname,"keystr") VALUES (?,?,"key?str")"))) (debug:print 0 *default-log-port* "db:create-initial-run-record") (debug:print 0 *default-log-port* "qrystr = " qrystr) (db:with-db dbstruct #f #t ;; run-id writable (lambda (dbdat db) (debug:print 0 *default-log-port* "lambda proc: dbdat: " dbdat " db: " db) (apply sqlite3:execute db qrystr run-id runname targvals))))) (define (db:insert-test dbstruct run-id test-rec) (let* ((testname (alist-ref "testname" test-rec equal?)) (item-path (alist-ref "item_path" test-rec equal?)) (id (db:get-test-id dbstruct run-id testname item-path)) (fieldvals (filter (lambda (x)(not (member (car x) '("id" "last_update")))) test-rec)) (setqry (conc "UPDATE tests SET "(string-intersperse (map (lambda (dat) (conc (car dat)"=?")) fieldvals) ",")" WHERE id=?;")) (insqry (conc "INSERT INTO tests ("(string-intersperse (map (lambda (x) (car x)) fieldvals) ",") ") VALUES ("(string-intersperse (make-list (length fieldvals) "?") ",")");"))) ;; (debug:print 0 *default-log-port* "id: "id"\nset: "setqry"\ninsqry: "insqry) (db:with-db dbstruct run-id #t (lambda (dbdat db) (if id (apply sqlite3:execute db setqry (append (map cdr fieldvals) (list id))) (apply sqlite3:execute db insqry (map cdr fieldvals))))))) ;; replace header and keystr with a call to runs:get-std-run-fields ;; ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; runpatts: patt1,patt2 ... ;; (define (db:get-runs dbstruct runpatt count offset keypatts) (let* ((res '()) |
︙ | ︙ | |||
2476 2477 2478 2479 2480 2481 2482 | (conc " LIMIT " count) "") (if (number? offset) (conc " OFFSET " offset) "")))) (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (db:with-db dbstruct #f #f | | < < < < < < > > | 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 | (conc " LIMIT " count) "") (if (number? offset) (conc " OFFSET " offset) "")))) (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (db:with-db dbstruct #f #f (lambda (dbdat db) (sqlite3:for-each-row (lambda (a . x) (set! res (cons (apply vector a x) res))) db qrystr ))) (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (vector header res))) ;; simple get-runs ;; ;; records used defined in dbfile ;; (define (db:simple-get-runs dbstruct runpatt count offset target last-update) (let* ((res '()) (keys (db:get-keys dbstruct)) (runpattstr (db:patt->like "runname" runpatt)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) (targstr (string-intersperse keys "||'/'||")) |
︙ | ︙ | |||
2519 2520 2521 2522 2523 2524 2525 | "") (if (number? offset) (conc " OFFSET " offset) ""))) ) (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " target: " target " offset: " offset " limit: " count) (db:with-db dbstruct #f #f | | | > > | | | | | | | 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 | "") (if (number? offset) (conc " OFFSET " offset) ""))) ) (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " target: " target " offset: " offset " limit: " count) (db:with-db dbstruct #f #f (lambda (dbdat db) (sqlite3:for-each-row (lambda (target id runname state status owner event_time) (set! res (cons (make-simple-run target id runname state status owner event_time) res))) db qrystr ))) (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " target: " target " offset: " offset " limit: " count) res)) ;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using cachedb db) ??? ;; ;; NOTE: This DOESN'T (necessarily) get the real run ids, but the number of the <number>.db!! (define (db:get-changed-run-ids since-time) (let* ((dbdir (common:make-tmpdir-name *toppath* "")) ;; (configf:lookup *configdat* "setup" "dbdir")) (alldbs (glob (conc *toppath* "/.mtdb/[0-9]*.db*"))) (changed (filter (lambda (dbfile) (> (file-modification-time dbfile) since-time)) alldbs))) (delete-duplicates (map (lambda (dbfile) (let* ((res (string-match ".*\\/(\\d+)\\.db*" dbfile))) (if res (string->number (cadr res)) (begin (debug:print 2 *default-log-port* "WARNING: Failed to process " dbfile " for run-id") 0)))) changed)))) ;; Get all targets from the db ;; (define (db:get-targets dbstruct) (let* ((res '()) (keys (db:get-keys dbstruct)) (header keys) ;; (map key:get-fieldname keys)) (keystr (keys->keystr keys)) (qrystr (conc "SELECT " keystr " FROM runs WHERE state != 'deleted';")) (seen (make-hash-table))) (db:with-db dbstruct #f #f (lambda (dbdat db) (sqlite3:for-each-row (lambda (a . x) (let ((targ (cons a x))) (if (not (hash-table-ref/default seen targ #f)) (begin (hash-table-set! seen targ #t) (set! res (cons (apply vector targ) res)))))) db qrystr) (debug:print-info 11 *default-log-port* "db:get-targets END qrystr: " qrystr ) (vector header res))))) ;; just get count of runs (define (db:get-num-runs dbstruct runpatt) (db:with-db dbstruct #f #f (lambda (dbdat db) (let ((numruns 0)) (debug:print-info 11 *default-log-port* "db:get-num-runs START " runpatt) (sqlite3:for-each-row (lambda (count) (set! numruns count)) db "SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt) (debug:print-info 11 *default-log-port* "db:get-num-runs END " runpatt) numruns)))) ;; just get count of runs (define (db:get-runs-cnt-by-patt dbstruct runpatt targetpatt keys) (db:with-db dbstruct #f #f (lambda (dbdat db) (let ((numruns 0) (qry-str #f) (key-patt "") (keyvals (if targetpatt (keys:target->keyval keys targetpatt) '()))) (for-each (lambda (keyval) (let* ((key (car keyval)) |
︙ | ︙ | |||
2634 2635 2636 2637 2638 2639 2640 | ;; (sqlite3#fold-row proc3670 init3671 db-or-stmt3672 . params3673)> ;; (define (db:get-raw-run-stats dbstruct run-id) (db:with-db dbstruct run-id #f | | | > > > | | | | | < | | | | | | | | | | | | | | | | | | | | 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 | ;; (sqlite3#fold-row proc3670 init3671 db-or-stmt3672 . params3673)> ;; (define (db:get-raw-run-stats dbstruct run-id) (db:with-db dbstruct run-id #f (lambda (dbdat db) (sqlite3:fold-row (lambda (res state status count) (cons (list state status count) res)) '() db "SELECT state,status,count(id) AS count FROM tests WHERE run_id=? AND NOT(uname='n/a' AND item_path='') GROUP BY state,status;" run-id)))) ;; Update run_stats for given run_id ;; input data is a list (state status count) ;; (define (db:update-run-stats dbstruct run-id stats-in) (let* ((stats (if (list? stats-in) stats-in (db:get-raw-run-stats dbstruct run-id)))) (mutex-lock! *db-transaction-mutex*) (db:with-db dbstruct #f #t (lambda (dbdat db) ;; remove previous data (let* ((stmt1 (sqlite3:prepare db "DELETE FROM run_stats WHERE run_id=? AND state=? AND status=?;")) (stmt2 (sqlite3:prepare db "INSERT INTO run_stats (run_id,state,status,count) VALUES (?,?,?,?);")) (res (sqlite3:with-transaction db (lambda () (for-each (lambda (dat) (sqlite3:execute stmt1 run-id (car dat)(cadr dat)) (apply sqlite3:execute stmt2 run-id dat)) stats))))) (sqlite3:finalize! stmt1) (sqlite3:finalize! stmt2) (mutex-unlock! *db-transaction-mutex*) res))))) (define (db:get-main-run-stats dbstruct run-id) (db:with-db dbstruct #f ;; this data comes from main #f (lambda (dbdat db) (sqlite3:fold-row (lambda (res state status count) (cons (list state status count) res)) '() db "SELECT state,status,count FROM run_stats WHERE run_id=? AND run_id IN (SELECT id FROM runs WHERE state NOT IN ('DELETED','deleted'));" run-id)))) |
︙ | ︙ | |||
2710 2711 2712 2713 2714 2715 2716 | (debug:print-info 0 *default-log-port* "TOTAL: " total " api calls since start."))) (define (db:get-all-run-ids dbstruct) (db:with-db dbstruct #f #f | | | 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 | (debug:print-info 0 *default-log-port* "TOTAL: " total " api calls since start."))) (define (db:get-all-run-ids dbstruct) (db:with-db dbstruct #f #f (lambda (dbdat db) (let ((run-ids '())) (sqlite3:for-each-row (lambda (run-id) (set! run-ids (cons run-id run-ids))) db "SELECT id FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;") (reverse run-ids))))) |
︙ | ︙ | |||
2734 2735 2736 2737 2738 2739 2740 | (let* ((totals (make-hash-table)) (curr (make-hash-table)) (res '()) (runs-info '())) ;; First get all the runname/run-ids (db:with-db dbstruct #f #f | | | | 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 | (let* ((totals (make-hash-table)) (curr (make-hash-table)) (res '()) (runs-info '())) ;; First get all the runname/run-ids (db:with-db dbstruct #f #f (lambda (dbdat db) (sqlite3:for-each-row (lambda (run-id runname) (set! runs-info (cons (list run-id runname) runs-info))) db "SELECT id,runname FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;"))) ;; If you change this to the more logical ASC please adjust calls to db:get-run-stats ;; for each run get stats data (for-each (lambda (run-info) ;; get the net state/status counts for this run (let* ((run-id (car run-info)) (run-name (cadr run-info))) (db:with-db dbstruct run-id #f (lambda (dbdat db) (sqlite3:for-each-row (lambda (state status count) (let ((netstate (if (equal? state "COMPLETED") status state))) (if (string? netstate) (begin (hash-table-set! totals netstate (+ (hash-table-ref/default totals netstate 0) count)) (hash-table-set! curr netstate (+ (hash-table-ref/default curr netstate 0) count)))))) |
︙ | ︙ | |||
2811 2812 2813 2814 2815 2816 2817 | (if offset (conc " OFFSET " offset) "") ";")) (debug:print-info 4 *default-log-port* "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) ;(print "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) (vector header (reverse | > | | | | | | | | | | | | | | | | | > > > > > | | < | | < | > | | | > | | > > > > > > > > > > > > > > | | | 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 | (if offset (conc " OFFSET " offset) "") ";")) (debug:print-info 4 *default-log-port* "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) ;(print "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) (vector header (reverse (db:with-db dbstruct #f #f ;; reads db, does not write to it. (lambda (dbdat db) (sqlite3:fold-row (lambda (res . r) (cons (list->vector r) res)) '() db qry-str runnamepatt))))))) ;; use (get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) ;; NOTE: Does NOT return a list of rows (or one row) for the first slot of the vector ;; this is inconsistent with get-runs but it makes some sense. ;; (define (db:get-run-info dbstruct run-id) ;;(if (hash-table-ref/default *run-info-cache* run-id #f) ;; (hash-table-ref *run-info-cache* run-id) (let* ((res (vector #f #f #f #f)) (keys (db:get-keys dbstruct)) (remfields (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update")) ;; "area_id")) (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) (db:with-db dbstruct #f #f (lambda (dbdat db) (sqlite3:for-each-row (lambda (a . x) (set! res (apply vector a x))) db (conc "SELECT " keystr " FROM runs WHERE id=?;") run-id))) (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) (let ((finalres (vector header res))) ;; (hash-table-set! *run-info-cache* run-id finalres) finalres))) (define (db:set-comment-for-run dbstruct run-id comment) (db:with-db dbstruct #f #f (lambda (dbdat db) (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment ;; (sdb:qry 'getid comment) run-id)))) ;; does not (obviously!) removed dependent data. But why not!!? (define (db:delete-run dbstruct run-id) (db:with-db dbstruct #f #t (lambda (dbdat db) (sqlite3:with-transaction db (lambda () (sqlite3:execute db "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id) (sqlite3:execute db "DELETE FROM test_data WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id) (sqlite3:execute db "UPDATE tests SET state='DELETED',comment='' WHERE run_id=?;" run-id) ;; (db:delay-if-busy dbdat) (sqlite3:execute db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id)))))) (define (db:update-run-event_time dbstruct run-id) (db:with-db dbstruct #f #t (lambda (dbdat db) (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)))) (define (db:lock/unlock-run dbstruct run-id lock unlock user) (db:with-db dbstruct #f #t (lambda (dbdat db) (let ((newlockval (if lock "locked" (if unlock "unlocked" "locked")))) ;; semi-failsafe (sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id) (sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);" user (conc newlockval " " run-id)) (debug:print-info 1 *default-log-port* "" newlockval " run number " run-id))))) (define (db:set-run-status dbstruct run-id status msg) (db:with-db dbstruct #f #t (lambda (dbdat db) (if msg (sqlite3:execute db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id) (sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id))))) (define (db:set-run-state-status-db dbdat db run-id state status ) (sqlite3:execute (db:get-cache-stmth dbdat db "UPDATE runs SET status=?,state=? WHERE id=?;") status state run-id)) (define (db:set-run-state-status dbstruct run-id state status ) (db:with-db dbstruct #f #t (lambda (dbdat db) (db:set-run-state-status-db dbdat db run-id state status)))) (define (db:get-run-status dbstruct run-id) (let ((res "n/a")) (db:with-db dbstruct #f #f (lambda (dbdat db) (sqlite3:for-each-row (lambda (status) (set! res status)) (db:get-cache-stmth dbdat db "SELECT status FROM runs WHERE id=?;" ) run-id) res)))) (define (db:get-run-state dbstruct run-id) (let ((res "n/a")) (db:with-db dbstruct #f #f (lambda (dbdat db) (sqlite3:for-each-row (lambda (status) (set! res status)) (db:get-cache-stmth dbdat db "SELECT state FROM runs WHERE id=?;" ) run-id) res)))) (define (db:get-run-state-status dbstruct run-id) (let ((res (cons "n/a" "n/a"))) (db:with-db dbstruct #f #f (lambda (dbdat db) (sqlite3:for-each-row (lambda (state status) (set! res (cons state status))) (db:get-cache-stmth dbdat db "SELECT state,status FROM runs WHERE id=?;" ) run-id) res)))) ;;====================================================================== ;; K E Y S ;;====================================================================== ;; get key val pairs for a given run-id ;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... ) (define (db:get-key-val-pairs dbstruct run-id) (let* ((keys (db:get-keys dbstruct)) (res '())) (db:with-db dbstruct #f #f (lambda (dbdat db) (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) (sqlite3:for-each-row (lambda (key-val) (set! res (cons (list key (if (string? key-val) key-val "")) res))) ;; replace non-string bad values with empty string to prevent crashes. This scenario can happen when Megatest is killed on updating the db db qry run-id))) keys))) (reverse res))) ;; get key vals for a given run-id (define (db:get-key-vals dbstruct run-id) (let* ((keys (db:get-keys dbstruct)) (res '())) (db:with-db dbstruct #f #f (lambda (dbdat db) (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (key-val) (set! res (cons (if (string? key-val) key-val "") res))) ;; check that the key-val is a string for cases where a crash injected bad data in the megatest.db |
︙ | ︙ | |||
2986 2987 2988 2989 2990 2991 2992 | thekey)) ;; Get run-ids for runs with same target but different runnames and NOT run-id ;; (define (db:get-prev-run-ids dbstruct run-id) (let* ((keyvals (db:get-key-val-pairs dbstruct run-id)) (kvalues (map cadr keyvals)) | | | | 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 | thekey)) ;; Get run-ids for runs with same target but different runnames and NOT run-id ;; (define (db:get-prev-run-ids dbstruct run-id) (let* ((keyvals (db:get-key-val-pairs dbstruct run-id)) (kvalues (map cadr keyvals)) (keys (db:get-keys dbstruct)) (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))) (let ((prev-run-ids '())) (if (null? keyvals) '() (begin (db:with-db dbstruct #f #f ;; #f means work with the zeroth db - i.e. the runs db (lambda (dbdat db) (apply sqlite3:for-each-row (lambda (id) (set! prev-run-ids (cons id prev-run-ids))) db (conc "SELECT id FROM runs WHERE " qrystr " AND state != 'deleted' AND id != ?;") (append kvalues (list run-id))))) prev-run-ids))))) |
︙ | ︙ | |||
3088 3089 3090 3091 3092 3093 3094 | (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 | | | 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 | (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 (dbdat 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)) |
︙ | ︙ | |||
3122 3123 3124 3125 3126 3127 3128 | -1 "-" "-")) ;; ;; 1. cache tests-match-qry ;; 2. compile qry and store in hash ;; 3. convert for-each-row to fold ;; | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | | | | > | | | 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 | -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 (dbdat 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 ") ") "") ))) (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry) (db:with-db dbstruct run-id #f (lambda (dbdat db) (sqlite3:fold-row (lambda (res id testname item-path state status event-time run-duration) ;; 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 event-time "" -1 -1 "" "-" item-path run-duration "-" "-") res)) '() db qry run-id (or last-update 0)))))) (define (db:get-testinfo-state-status dbstruct run-id test-id) (db:with-db dbstruct run-id #f (lambda (dbdat db) (let* ((res #f) (stmth (db:get-cache-stmth dbdat db "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=? and run_id=?;"))) (sqlite3:for-each-row (lambda (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 (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-"))) ;; db ;; "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=? and run_id=?;" stmth test-id run-id) res)))) ;; get a useful subset of the tests data (used in dashboard ;; use db:mintest-get-{id ,run_id,testname ...} ;; (define (db:get-tests-for-run-mindata dbstruct run-id testpatt states statuses not-in) (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f "id,run_id,testname,state,status,event_time,item_path" 0 #f)) |
︙ | ︙ | |||
3204 3205 3206 3207 3208 3209 3210 | (db:get-all-run-ids dbstruct))) res)) ;; Convert calling routines to get list of run-ids and loop, do not use the get-tests-for-runs ;; (define (db:delete-test-records dbstruct run-id test-id) | | | | | | | | | < | < > > | | | | | | | | > > > > > > > > > > > > | 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 | (db:get-all-run-ids dbstruct))) res)) ;; Convert calling routines to get list of run-ids and loop, do not use the get-tests-for-runs ;; (define (db:delete-test-records dbstruct run-id test-id) (db:general-call dbstruct run-id 'delete-test-step-records (list test-id)) (db:general-call dbstruct run-id 'delete-test-data-records (list test-id)) (db:with-db dbstruct run-id #t (lambda (dbdat db) (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id)))) ;; (define (db:delete-old-deleted-test-records dbstruct run-id) (let* ((targtime (- (current-seconds) (or (configf:lookup-number *configdat* "setup" "keep-deleted-records") (* 7 24 60 60)))) ;; cleanup if over one week old (mtdbfile (dbmod:run-id->full-dbfname dbstruct run-id)) (qry1 "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE state='DELETED' AND event_time<?);") (qry2 "DELETE FROM test_data WHERE test_id IN (SELECT id FROM tests WHERE state='DELETED' AND event_time<?);") (qry3 "DELETE FROM tests WHERE state='DELETED' AND event_time<?;") (delproc (lambda (db) (sqlite3:with-transaction db (lambda () (sqlite3:execute db qry1 targtime) (sqlite3:execute db qry2 targtime) (sqlite3:execute db qry3 targtime)))))) ;; first the /tmp db (db:with-db dbstruct run-id #t (lambda (dbdat db) (delproc db))) (if (and (file-exists? mtdbfile) (file-write-access? mtdbfile)) (let* ((db (sqlite3:open-database mtdbfile))) (delproc db) (sqlite3:finalize! db))))) ;; set tests with state currstate and status currstatus to newstate and newstatus ;; use currstate = #f and or currstatus = #f to apply to any state or status respectively ;; WARNING: SQL injection risk. NB// See new but not yet used "faster" version below ;; ;; AND NOT (item_path='' AND testname in (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));"))) ;; (debug:print 0 *default-log-port* "QRY: " qry) |
︙ | ︙ | |||
3251 3252 3253 3254 3255 3256 3257 | (if currstatus (conc "status='" currstatus "' AND ") "") " run_id=? AND testname LIKE ?;")) (test-id (db:get-test-id dbstruct run-id testname ""))) (db:with-db dbstruct run-id #t | | | < < | > > > | | | | | | | | | | | | | > | | | | | | > > | | | < < < < | | | | | | | | | | | | | | | | | | | | | 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 | (if currstatus (conc "status='" currstatus "' AND ") "") " run_id=? AND testname LIKE ?;")) (test-id (db:get-test-id dbstruct run-id testname ""))) (db:with-db dbstruct run-id #t (lambda (dbdat db) (sqlite3:execute db qry (or newstate currstate "NOT_STARTED") (or newstatus currstate "UNKNOWN") run-id testname))) (if test-id (begin (set! test-ids (cons test-id test-ids)) (mt:process-triggers dbstruct run-id test-id newstate newstatus))))) testnames) test-ids)) ;; ;; speed up for common cases with a little logic ;; ;; NB// Ultimately this will be deprecated in deference to mt:test-set-state-status-by-id ;; ;; NOTE: run-id is not used ;; ;; (define (db:test-set-state-status dbstruct run-id test-id newstate newstatus newcomment) (db:with-db dbstruct run-id #t (lambda (dbdat db) (db:test-set-state-status-db db run-id test-id newstate newstatus newcomment)))) (define (db:test-set-state-status-db db run-id test-id newstate newstatus newcomment) (cond ((and newstate newstatus newcomment) (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment ;; (sdb:qry 'getid newcomment) test-id)) ((and newstate newstatus) (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id)) (else (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id)) (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)) ;; NOTE: Moved into calling function ) ;; NEW BEHAVIOR: Count tests running in all runs! ;; (define (db:get-count-tests-running dbstruct run-id) ;; fastmode) (let* ((qry "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 (dbdat db) (let* ((stmth (db:get-cache-stmth dbdat 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 (dbdat 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 (dbdat db) (let* ((stmth (db:get-cache-stmth dbdat 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 (dbdat 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 dbdat 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 (dbdat db) ;(print "SELECT count(id) FROM tests WHERE state not in ('COMPLETED', 'DELETED') AND run_id=" run-id) (sqlite3:first-result db "SELECT count(id) FROM tests WHERE state not in ('COMPLETED', 'DELETED') AND run_id=?;" run-id)))) (define (db:get-count-tests-running-in-jobgroup dbstruct run-id jobgroup) (if (not jobgroup) 0 ;; (let ((testnames '())) ;; get the testnames (db:with-db dbstruct #f #f (lambda (dbdat db) (sqlite3:for-each-row (lambda (testname) (set! testnames (cons testname testnames))) db "SELECT testname FROM test_meta WHERE jobgroup=?" jobgroup))) ;; get the jobcount NB// EXTEND THIS TO OPPERATE OVER ALL RUNS? (if (not (null? testnames)) (db:with-db dbstruct run-id #f (lambda (dbdat db) (sqlite3:first-result db (conc "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND testname in ('" (string-intersperse testnames "','") "') AND NOT (uname = 'n/a' AND item_path='');")) ;; should this include the (uname = 'n/a' ...) ??? )) 0)))) ;; tags: '("tag%" "tag2" "%ag6") ;; ;; done with run when: ;; 0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING (define (db:estimated-tests-remaining dbstruct run-id) (db:with-db dbstruct run-id #f (lambda (dbdat db) (sqlite3:first-result db "SELECT count(id) FROM tests WHERE state in ('LAUNCHED','NOT_STARTED','REMOTEHOSTSTART','RUNNING','KILLREQ') AND run_id=?;") run-id))) ;; map run-id, testname item-path to test-id (define (db:get-test-id dbstruct run-id testname item-path) (db:with-db dbstruct run-id #f (lambda (dbdat db) (db:first-result-default db "SELECT id FROM tests WHERE testname=? AND item_path=? AND run_id=?;" #f ;; the default testname item-path run-id)))) ;; overload the unused attemptnum field for the process id of the runscript or ;; ezsteps step script in progress ;; (define (db:test-set-top-process-pid dbstruct run-id test-id pid) (db:with-db dbstruct run-id #t (lambda (dbdat db) (sqlite3:execute db "UPDATE tests SET attemptnum=? WHERE id=?;" pid test-id)))) (define (db:test-get-top-process-pid dbstruct run-id test-id) (db:with-db dbstruct run-id #f (lambda (dbdat db) (db:first-result-default db "SELECT attemptnum FROM tests WHERE id=? AND run_id=?;" #f test-id run-id)))) (define db:test-record-fields '("id" "run_id" "testname" "state" "status" "event_time" "host" "cpuload" "diskfree" "uname" "rundir" "item_path" "run_duration" "final_logf" "comment" "shortdir" "attemptnum" "archived" "last_update")) ;; fields *must* be a non-empty list ;; |
︙ | ︙ | |||
3461 3462 3463 3464 3465 3466 3467 | #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 | | | | | | 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 | #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 #t (lambda (dbdat 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 (lambda (dbdat db) (sqlite3:for-each-row (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived) res))) db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE state != 'DELETED' AND run_id=?;") run-id))) res)) (define (db:replace-test-records dbstruct run-id testrecs) (db:with-db dbstruct run-id #t (lambda (dbdat db) (let* ((qmarks (string-intersperse (make-list (length db:test-record-fields) "?") ",")) (qrystr (conc "INSERT OR REPLACE INTO tests (" db:test-record-qry-selector ") VALUES (" qmarks ") WHERE run_id=?;")) (qry (sqlite3:prepare db qrystr))) (debug:print 0 *default-log-port* "INFO: migrating test records for run with id " run-id) (sqlite3:with-transaction db (lambda () |
︙ | ︙ | |||
3510 3511 3512 3513 3514 3515 3516 | (if (>= test-id min-test-id) test-id (let loop ((new-id min-test-id)) (let ((test-id-found #f)) (sqlite3:for-each-row (lambda (id) (set! test-id-found id)) | | | | | | | > > | | > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > | > > > | | | | | | | | | | | | | < < < < < < < < < < < < < < < | < | | | | | > | < | | | > | < | | | | | | | 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 | (if (>= test-id min-test-id) test-id (let loop ((new-id min-test-id)) (let ((test-id-found #f)) (sqlite3:for-each-row (lambda (id) (set! test-id-found id)) (dbr:dbdat-dbh mtdb) "SELECT id FROM tests WHERE id=?;" new-id) ;; if test-id-found then need to try again (if test-id-found (loop (+ new-id 1)) (begin (debug:print-info 0 *default-log-port* "New test id " new-id " selected for test with id " test-id) (sqlite3:execute mtdb "UPDATE tests SET id=? WHERE id=?;" new-id test-id))))))) ;; move test ids into the 30k * run_id range ;; (define (db:prep-megatest.db-adj-test-ids mtdb run-id testrecs) (debug:print-info 0 *default-log-port* "Adjusting test ids in megatest.db for run " run-id) (let ((min-test-id (* run-id 30000))) (for-each (lambda (testrec) (let* ((test-id (vector-ref testrec (db:field->number "id" db:test-record-fields)))) (db:adj-test-id (dbr:dbdat-dbh mtdb) min-test-id test-id))) testrecs))) ;; 1. move test ids into the 30k * run_id range ;; 2. move step ids into the 30k * run_id range ;; (define (db:prep-megatest.db-for-migration mtdb) (let* ((run-ids (db:get-all-run-ids mtdb))) (for-each (lambda (run-id) (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id))) (db:prep-megatest.db-adj-test-ids (dbr:dbdat-dbh mtdb) run-id testrecs))) run-ids))) ;; Get test data using test_id ;; (define (db:get-test-info-by-id dbstruct run-id test-id) (db:with-db dbstruct run-id #f (lambda (dbdat db) (let ((res #f)) (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived last-update) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived last-update))) db ;; (db:get-cache-stmth dbdat db ;; (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=? AND run_id=?;")) (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=? AND run_id=?;") test-id run-id) res)))) ;; Get test state, status using test_id ;; (define (db:get-test-state-status-by-id dbstruct run-id test-id) (db:with-db dbstruct run-id #f (lambda (dbdat db) (let ((res (cons #f #f)) (stmth (db:get-cache-stmth dbdat db "SELECT state,status FROM tests WHERE id=? AND run_id=?;"))) (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test (lambda (state status) (cons state status)) ;; db stmth ;;"SELECT state,status FROM tests WHERE id=? AND run_id=?;" ;; stmth try not compiling this one - yes, this fixed the bind issue test-id run-id) res)))) ;; Use db:test-get* to access ;; Get test data using test_ids. NB// Only works within a single run!! ;; (define (db:get-test-info-by-ids dbstruct run-id test-ids) (db:with-db dbstruct run-id #f (lambda (dbdat db) (let ((res '())) (sqlite3:for-each-row (lambda (a . b) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 (set! res (cons (apply vector a b) res))) db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in (" (string-intersperse (map conc test-ids) ",") ");")) res)))) ;; try every second until tries times proc ;; (define (db:keep-trying-until-true proc params tries) (let* ((res (apply proc params))) (if res res (if (> tries 0) (begin (thread-sleep! 1) (db:keep-trying-until-true proc params (- tries 1))) (begin ;; (debug:print-info 0 *default-log-port* "proc never returned true, params="params) (print"db:keep-trying-until-true proc never returned true, proc = " proc " params =" params " tries = " tries) #f))))) (define (db:get-test-info dbstruct run-id test-name item-path) (db:with-db dbstruct run-id #f (lambda (dbdat db) (db:get-test-info-db db run-id test-name item-path)))) (define (db:get-test-info-db db run-id test-name item-path) (let ((res #f)) (sqlite3:for-each-row (lambda (a . b) (set! res (apply vector a b))) db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=? AND run_id=?;") test-name item-path run-id) res)) (define (db:test-get-rundir-from-test-id dbstruct run-id test-id) (db:with-db dbstruct run-id #f (lambda (dbdat db) (db:first-result-default db "SELECT rundir FROM tests WHERE id=? AND run_id=?;" #f ;; default result test-id run-id)))) (define (db:get-test-times dbstruct run-name target) (let ((res `()) (qry (conc "select testname, item_path, run_duration, " (string-join (db:get-keys dbstruct) " || '/' || ") " as target from tests inner join runs on tests.run_id = runs.id where runs.runname = ? and target = ? ;"))) (db:with-db dbstruct #f ;; this is for the main runs db #f ;; does not modify db (lambda (dbdat db) (sqlite3:for-each-row (lambda (test-name item-path test-time target ) (set! res (cons (vector test-name item-path test-time) res))) db qry run-name target) res)))) ;;====================================================================== ;; S T E P S ;;====================================================================== (define (db:teststep-set-status! dbstruct run-id test-id teststep-name state-in status-in comment logfile) (db:with-db dbstruct run-id #t (lambda (dbdat db) (sqlite3:execute db "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);" test-id teststep-name state-in status-in (current-seconds) (if comment comment "") (if logfile logfile ""))))) (define (db:delete-steps-for-test! dbstruct run-id test-id) ;; TODO: figure out why status is the key field rather than state (note: CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state) ) (db:with-db dbstruct run-id #t (lambda (dbdat db) (sqlite3:execute db "UPDATE test_steps set status='DELETED' where test_id=?" ;; and run_id=? !! - run_id not in table (bummer) TODO: get run_id into schema for test_steps test-id)))) ;; db-get-test-steps-for-run (define (db:get-steps-for-test dbstruct run-id test-id) (db:with-db dbstruct run-id #f (lambda (dbdat db) (let* ((res '())) (sqlite3:for-each-row (lambda (id test-id stepname state status event-time logfile comment) (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment) res))) db "SELECT id,test_id,stepname,state,status,event_time,logfile,comment FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) (reverse res))))) (define (db:get-steps-info-by-id dbstruct run-id test-step-id) (db:with-db dbstruct run-id #f (lambda (dbdat db) (let* ((res (vector #f #f #f #f #f #f #f #f #f))) (sqlite3:for-each-row (lambda (id test-id stepname state status event-time logfile comment last-update) (set! res (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment last-update))) db "SELECT id,test_id,stepname,state,status,event_time,logfile,comment,last_update FROM test_steps WHERE id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-step-id) res)))) (define (db:get-steps-data dbstruct run-id test-id) (db:with-db dbstruct run-id #f (lambda (dbdat db) (let ((res '())) (sqlite3:for-each-row (lambda (id test-id stepname state status event-time logfile) (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) db "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) (reverse res))))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== (define (db:get-data-info-by-id dbstruct run-id 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 run-id #f (lambda (dbdat db) (let* ((stmth (db:get-cache-stmth dbdat 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) (let* ((fail-count 0) (pass-count 0)) (db:with-db dbstruct run-id #t (lambda (dbdat db) (sqlite3:for-each-row (lambda (fcount pcount) (set! fail-count fcount) (set! pass-count pcount)) db "SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count, (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;" test-id test-id) ;; Now rollup the counts to the central megatest.db (db:general-call dbstruct run-id 'pass-fail-counts (list pass-count fail-count test-id)) ;; if the test is not FAIL then set status based on the fail and pass counts. (db:general-call dbstruct run-id 'test_data-pf-rollup (list test-id test-id test-id test-id)))))) ;; each section is a rule except "final" which is the final result ;; ;; [rule-5] ;; operator in ;; section LogFileBody ;; desc Output voltage |
︙ | ︙ | |||
3846 3847 3848 3849 3850 3851 3852 | ;; foo,bra, 1.2, pass, silly stuff ;; faz,bar, 10, 8mA, , ,"this is a comment" ;; EOF (define (db:csv->test-data dbstruct run-id test-id csvdata) (debug:print 4 *default-log-port* "test-id " test-id ", csvdata: " csvdata) (db:with-db | | | | 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 | ;; foo,bra, 1.2, pass, silly stuff ;; faz,bar, 10, 8mA, , ,"this is a comment" ;; EOF (define (db:csv->test-data dbstruct run-id test-id csvdata) (debug:print 4 *default-log-port* "test-id " test-id ", csvdata: " csvdata) (db:with-db dbstruct #f #t (lambda (dbdat db) (let* ((csvlist (csv->list (make-csv-reader (open-input-string csvdata) '((strip-leading-whitespace? #t) (strip-trailing-whitespace? #t)))))) ;; (csv->list csvdata))) (for-each (lambda (csvrow) (let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9)) |
︙ | ︙ | |||
3910 3911 3912 3913 3914 3915 3916 | ;; This routine moved from tdb.scm, tdb:read-test-data ;; (define (db:read-test-data dbstruct run-id test-id categorypatt) (let* ((res '())) (db:with-db dbstruct #f #f | | | | | | 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 | ;; This routine moved from tdb.scm, tdb:read-test-data ;; (define (db:read-test-data dbstruct run-id test-id categorypatt) (let* ((res '())) (db:with-db dbstruct #f #f (lambda (dbdat db) (sqlite3:for-each-row (lambda (id test_id category variable value expected tol units comment status type) (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) db "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt) (reverse res))))) ;; This routine moved from tdb.scm, :read-test-data ;; (define (db:read-test-data-varpatt dbstruct run-id test-id categorypatt varpatt) (let* ((res '())) (db:with-db dbstruct #f #f (lambda (dbdat db) (sqlite3:for-each-row (lambda (id test_id category variable value expected tol units comment status type) (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) db "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? AND variable LIKE ? ORDER BY category,variable;" test-id categorypatt varpatt) (reverse res))))) ;;====================================================================== ;; Misc. test related queries ;;====================================================================== (define (db:get-run-ids-matching-target dbstruct keynames target res runname testpatt statepatt statuspatt) (db:with-db dbstruct #f #f (lambda (dbdat db) (let* ((row-ids '()) (keystr (string-intersperse (map (lambda (key val) (conc key " like '" val "'")) keynames (string-split target "/")) " AND ")) |
︙ | ︙ | |||
3967 3968 3969 3970 3971 3972 3973 | (define (db:test-get-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname) (let* ((testqry (tests:match->sqlqry testpatt)) (tstsqry (conc "SELECT rundir FROM tests WHERE run_id=? AND " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;"))) (db:with-db dbstruct run-id #f | | | | 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 | (define (db:test-get-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname) (let* ((testqry (tests:match->sqlqry testpatt)) (tstsqry (conc "SELECT rundir FROM tests WHERE run_id=? AND " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;"))) (db:with-db dbstruct run-id #f (lambda (dbdat db) (sqlite3:for-each-row (lambda (p) (set! res (cons p res))) db tstsqry run-id) res)))) (define (db:test-toplevel-num-items dbstruct run-id testname) (db:with-db dbstruct run-id #f (lambda (dbdat db) (let ((res 0)) (sqlite3:for-each-row (lambda (num-items) (set! res num-items)) db "SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state NOT IN ('DELETED');" run-id |
︙ | ︙ | |||
4032 4033 4034 4035 4036 4037 4038 | msg))) ;; crude reply for when things go awry ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize)))) (else msg))) ;; rpc ;; ; This is to be the big daddy call NOPE: Replaced by db:set-state-status-and-roll-up-items ;; ; ;; define (db:test-set-state-status dbstruct run-id test-id state status msg) | | | > > | > | > > | | | | | | | | > > | | | | | < | | > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | < < < | | | > | | | < > > > > > | | | < < < | | | | | | < | | | < | 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 | msg))) ;; crude reply for when things go awry ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize)))) (else msg))) ;; rpc ;; ; This is to be the big daddy call NOPE: Replaced by db:set-state-status-and-roll-up-items ;; ; ;; define (db:test-set-state-status dbstruct run-id test-id state status msg) ;; (let ((dbdat (db:get-subdb dbstruct run-id))) ;; (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) ;; (db:general-call dbdat 'set-test-start-time (list test-id))) ;; ;; (if msg ;; ;; (db:general-call dbdat 'state-status-msg (list state status msg test-id)) ;; ;; (db:general-call dbdat 'state-status (list state status test-id))) ;; (db:set-state-status-and-roll-up-items dbstruct run-id test-id #f state status msg) ;; ;; process the test_data table ;; (if (and test-id state status (equal? status "AUTO")) ;; (db:test-data-rollup dbstruct run-id test-id status)) ;; (mt:process-triggers dbstruct run-id test-id state status))) ;; state is the priority rollup of all states ;; status is the priority rollup of all completed statesfu ;; ;; if test-name is an integer work off that as test-id instead of test-name test-path ;; (define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment) ;; establish info on incoming test followed by info on top level test ;; BBnote - for mode itemwait, linkage between upstream test & matching item status is propagated to run queue in db:prereqs-not-met (let* ((testdat (if (number? test-name) (db:get-test-info-by-id dbstruct run-id test-name) ;; test-name is actually a test-id (db:keep-trying-until-true ;; in our threaded stuff this call could happen before the test is registered (maybe?) db:get-test-info (list dbstruct run-id test-name item-path) 10))) (test-id (db:test-get-id testdat)) (test-name (if (number? test-name) (db:test-get-testname testdat) test-name)) (item-path (db:test-get-item-path testdat)) (tl-testdat (db:get-test-info dbstruct run-id test-name "")) (tl-test-id (if tl-testdat (db:test-get-id tl-testdat) #f)) (new-state-eh #f) (new-status-eh #f)) (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) (db:general-call dbstruct run-id 'set-test-start-time (list test-id))) (mutex-lock! *db-transaction-mutex*) (db:with-db dbstruct run-id #t (lambda (dbdat db) (let ((tr-res (sqlite3:with-transaction db (lambda () ;; NB// Pass the db so it is part fo the transaction (db:test-set-state-status-db db run-id test-id state status comment) ;; this call sets the item state/status (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item (let* ((state-status-counts (db:get-all-state-status-counts-for-test db run-id test-name item-path state status)) ;; item-path is used to exclude current state/status of THIS test (state-statuses (db:roll-up-rules state-status-counts state status)) (newstate (car state-statuses)) (newstatus (cadr state-statuses))) (set! new-state-eh newstate) (set! new-status-eh newstatus) (debug:print 4 *default-log-port* "BB> tl-test-id="tl-test-id" ; "test-name":"item-path" newstate="newstate" newstatus="newstatus" len(sscs)="(length state-status-counts) " state-status-counts: " (apply conc (map (lambda (x) (conc (with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | ")) state-status-counts))); end debug:print (if tl-test-id (db:test-set-state-status-db db run-id tl-test-id newstate newstatus #f)) ;; we are still in the transaction - must access the db and not the dbstruct )))))) (mutex-unlock! *db-transaction-mutex*) (if (and test-id state status (equal? status "AUTO")) (db:test-data-rollup dbstruct run-id test-id status)) (if new-state-eh ;; moved from db:test-set-state-status (mt:process-triggers dbstruct run-id test-id new-state-eh new-status-eh)) tr-res))))) (define (db:roll-up-rules state-status-counts state status) (if (null? state-status-counts) '(#f #f) (let* ((running (length (filter (lambda (x) (member (dbr:counts-state x) *common:running-states*)) state-status-counts))) (bad-not-started (length (filter (lambda (x) (and (equal? (dbr:counts-state x) "NOT_STARTED") (not (member (dbr:counts-status x) *common:not-started-ok-statuses*)))) state-status-counts))) (all-curr-states (common:special-sort ;; worst -> best (sort of) (delete-duplicates (if (and state (not (member state *common:dont-roll-up-states*))) (cons state (map dbr:counts-state state-status-counts)) (map dbr:counts-state state-status-counts))) *common:std-states* >)) (all-curr-statuses (common:special-sort ;; worst -> best (delete-duplicates (if (and state status (not (member state *common:dont-roll-up-states*))) (cons status (map dbr:counts-status state-status-counts)) (map dbr:counts-status state-status-counts))) *common:std-statuses* >)) (non-completes (filter (lambda (x) (not (member x (cons "COMPLETED" *common:dont-roll-up-states*)))) all-curr-states)) (preq-fails (filter (lambda (x) (equal? x "PREQ_FAIL")) all-curr-statuses)) (num-non-completes (length non-completes)) (newstate (cond ((> running 0) "RUNNING") ;; anything running, call the situation running ((> (length preq-fails) 0) "NOT_STARTED") ((> bad-not-started 0) "COMPLETED") ;; we have an ugly situation, it is completed in the sense we cannot do more. ((> num-non-completes 0) (car non-completes)) ;; (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) ;; only rollup DELETED if all DELETED (else (car all-curr-states)))) (newstatus (cond ((> (length preq-fails) 0) "PREQ_FAIL") ((or (> bad-not-started 0) (and (equal? newstate "NOT_STARTED") (> num-non-completes 0))) "STARTED") (else (car all-curr-statuses))))) (debug:print-info 2 *default-log-port* "\n--> probe db:set-state-status-and-roll-up-items: " "\n--> state-status-counts: "(map dbr:counts->alist state-status-counts) "\n--> running: "running "\n--> bad-not-started: "bad-not-started "\n--> non-non-completes: "num-non-completes "\n--> non-completes: "non-completes "\n--> all-curr-states: "all-curr-states "\n--> all-curr-statuses: "all-curr-statuses "\n--> newstate "newstate "\n--> newstatus "newstatus "\n\n") ;; NB// Pass the db so it is part of the transaction (list newstate newstatus)))) (define (db:set-state-status-and-roll-up-run dbstruct run-id curr-state curr-status) (mutex-lock! *db-transaction-mutex*) (db:with-db dbstruct run-id #t (lambda (dbdat db) (let ((tr-res (sqlite3:with-transaction db (lambda () (let* ((state-status-counts (db:get-all-state-status-counts-for-run-db dbdat db run-id)) (state-statuses (db:roll-up-rules state-status-counts #f #f )) (newstate (car state-statuses)) (newstatus (cadr state-statuses))) (if (or (not (eq? newstate curr-state)) (not (eq? newstatus curr-status))) (db:set-run-state-status-db dbdat db run-id newstate newstatus ))))))) (mutex-unlock! *db-transaction-mutex*) tr-res)))) (define (db:get-all-state-status-counts-for-run-db dbdat db run-id) (sqlite3:map-row (lambda (state status count) (make-dbr:counts state: state status: status count: count)) (db:get-cache-stmth dbdat db "SELECT state,status,count(id) FROM tests WHERE run_id=? GROUP BY state,status;") run-id )) (define (db:get-all-state-status-counts-for-run dbstruct run-id) (db:with-db dbstruct #f #f (lambda (dbdat db) (db:get-all-state-status-counts-for-run-db dbdat db run-id)))) ;; 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 db run-id test-name item-path item-state-in item-status-in) (let* ((test-info (db:get-test-info-db db 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 (sqlite3:map-row (lambda (state status count) (make-dbr:counts state: state status: status count: count)) db ;; ignore current item because we have changed its value in the current transation so this select will see the old value. "SELECT state,status,count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND item_path !=? GROUP BY state,status;" run-id test-name item-path)) ;; add current item to tally outside of sql query (match-countrec-lambda (lambda (countrec) (and (equal? (dbr:counts-state countrec) item-state) (equal? (dbr:counts-status countrec) item-status)))) (already-have-count-rec-list (filter match-countrec-lambda other-items-count-recs)) ;; will have either 0 or 1 count recs depending if another item shares this item's state/status (updated-count-rec (if (null? already-have-count-rec-list) (make-dbr:counts state: item-state status: item-status count: 1) (let* ((our-count-rec (car already-have-count-rec-list)) (new-count (add1 (dbr:counts-count our-count-rec)))) (make-dbr:counts state: item-state status: item-status count: new-count)))) (nonmatch-countrec-lambda (lambda (countrec) (not (match-countrec-lambda countrec)))) (unrelated-rec-list (filter nonmatch-countrec-lambda other-items-count-recs))) (cons updated-count-rec unrelated-rec-list))) ;; (define (db:get-all-item-states db run-id test-name) ;; (sqlite3:map-row ;; (lambda (a) a) ;; db ;; "SELECT DISTINCT state FROM tests WHERE item_path != '' AND state != 'DELETED' AND run_id=? AND testname=?" |
︙ | ︙ | |||
4243 4244 4245 4246 4247 4248 4249 | ;; run-id test-name)) (define (db:test-get-logfile-info dbstruct run-id test-name) (db:with-db dbstruct run-id #f | | | 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 | ;; run-id test-name)) (define (db:test-get-logfile-info dbstruct run-id test-name) (db:with-db dbstruct run-id #f (lambda (dbdat db) (let ((res #f)) (sqlite3:for-each-row (lambda (path final_logf) ;; (let ((path (sdb:qry 'getstr path-id)) ;; (final_logf (sdb:qry 'getstr final_logf-id))) (set! logf final_logf) (set! res (list path final_logf)) |
︙ | ︙ | |||
4417 4418 4419 4420 4421 4422 4423 | flush sync set-verbosity killserver )) (define (db:login dbstruct calling-path calling-version client-signature) | | > | > > | > | | | | | | 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 | flush sync set-verbosity killserver )) (define (db:login dbstruct calling-path calling-version client-signature) (cond ((not (equal? calling-path *toppath*)) (list #f "Login failed due to mismatch paths: " calling-path ", " *toppath*)) ;; ((not (equal? *run-id* run-id)) ;; (list #f "Login failed due to mismatch run-id: " run-id ", " *run-id*)) ((not (equal? megatest-version calling-version)) (list #t (conc "Login warning due to mismatch megatest version: " calling-version ", " megatest-version))) (else (hash-table-set! *logged-in-clients* client-signature (current-seconds)) '(#t "successful login")))) ;; NO WAY TO KNOW IF IT MODIFIES THE DB BUT NEARLY ALL ARE UPDATES/INSERTS ;; (define (db:general-call dbstruct run-id stmtname params) ;; Why is db:lookup-query above not used here to get the query? (let ((query (let ((q (alist-ref (if (string? stmtname) (string->symbol stmtname) stmtname) db:queries))) (if q (car q) #f)))) (db:with-db dbstruct run-id #t (lambda (dbdat db) (apply sqlite3:execute db query params) #t)))) ;; get a summary of state and status counts to calculate a rollup ;; (define (db:get-state-status-summary dbstruct run-id testname) (let ((res '())) (db:with-db dbstruct run-id #f (lambda (dbdat db) (sqlite3:for-each-row (lambda (state status count) (set! res (cons (vector state status count) res))) db "SELECT state,status,count(state) FROM tests WHERE run_id=? AND testname=? AND item_path='' GROUP BY state,status;" run-id testname) res)))) (define (db:get-latest-host-load dbstruct raw-hostname) (let* ((hostname (string-substitute "\\..*$" "" raw-hostname)) (res (cons -1 0))) (db:with-db dbstruct #f #f (lambda (dbdat db) (sqlite3:for-each-row (lambda (cpuload update-time) (set! res (cons cpuload update-time))) db "SELECT tr.cpuload, tr.update_time FROM test_rundat tr, tests t WHERE t.host=? AND tr.cpuload != -1 AND tr.test_id=t.id ORDER BY tr.update_time DESC LIMIT 1;" hostname))) res )) (define (db:set-top-level-from-items dbstruct run-id testname) |
︙ | ︙ | |||
4505 4506 4507 4508 4509 4510 4511 | (selstr (string-intersperse keys ",")) (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")) (keyvals #f) (tests-hash (make-hash-table))) ;; first look up the key values from the run selected by run-id (db:with-db dbstruct #f #f | | | | 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 | (selstr (string-intersperse keys ",")) (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")) (keyvals #f) (tests-hash (make-hash-table))) ;; first look up the key values from the run selected by run-id (db:with-db dbstruct #f #f (lambda (dbdat db) (sqlite3:for-each-row (lambda (a . b) (set! keyvals (cons a b))) db (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id))) (if (not keyvals) '() (let ((prev-run-ids '())) (db:with-db dbstruct #f #f (lambda (dbdat db) (apply sqlite3:for-each-row (lambda (id) (set! prev-run-ids (cons id prev-run-ids))) db (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))))) ;; collect all matching tests for the runs then ;; extract the most recent test and return that. |
︙ | ︙ | |||
4552 4553 4554 4555 4556 4557 4558 | (loop (car tal)(cdr tal)))))))))) ;; Function recursively checks if <db>.journal exists; if yes means db busy; call itself after delayed interval ;; return the sqlite3 db handle if possible ;; (define (db:delay-if-busy dbdat #!key (count 6)) (if (not (configf:lookup *configdat* "server" "delay-on-busy")) | | | | | 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 | (loop (car tal)(cdr tal)))))))))) ;; Function recursively checks if <db>.journal exists; if yes means db busy; call itself after delayed interval ;; return the sqlite3 db handle if possible ;; (define (db:delay-if-busy dbdat #!key (count 6)) (if (not (configf:lookup *configdat* "server" "delay-on-busy")) (and dbdat (dbr:dbdat-dbh dbdat)) (if dbdat (let* ((dbpath (dbr:dbdat-dbfile dbdat)) (db (dbr:dbdat-dbh dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline (dbfj (conc dbpath "-journal"))) (if (handle-exceptions exn (begin (debug:print-info 0 *default-log-port* "WARNING: failed to test for existance of " dbfj ", exn=" exn) (thread-sleep! 1) (db:delay-if-busy count (- count 1))) |
︙ | ︙ | |||
4595 4596 4597 4598 4599 4600 4601 | (define (db:test-get-records-for-index-file dbstruct run-id test-name) (let ((res '())) (db:with-db dbstruct run-id #f | | | > > > > > > > > | | | | | | | | | | | | > > | | | | | | | 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 | (define (db:test-get-records-for-index-file dbstruct run-id test-name) (let ((res '())) (db:with-db dbstruct run-id #f (lambda (dbdat db) (sqlite3:for-each-row (lambda (id itempath state status run_duration logf comment) (set! res (cons (vector id itempath state status run_duration logf comment) res))) db "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE testname=? AND item_path != '' AND run_id=?;" ;; BUG! WHY NO run_id? test-name run-id) res)))) ;;====================================================================== ;; Tests meta data ;;====================================================================== ;; returns a hash table of tags to tests ;; (define (db:get-tests-tags dbstruct) (db:with-db dbstruct #f #f (lambda (dbdat db) (let* ((res (make-hash-table))) (sqlite3:for-each-row (lambda (testname tags-in) (let ((tags (string-split tags-in ","))) (for-each (lambda (tag) (hash-table-set! res tag (delete-duplicates (cons testname (hash-table-ref/default res tag '()))))) tags))) db "SELECT testname,tags FROM test_meta") (hash-table->alist res))))) ;; testmeta doesn't change, we can cache it for up too an hour (define *db:testmeta-cache* (make-hash-table)) (define *db:testmeta-last-update* 0) ;; read the record given a testname (define (db:testmeta-get-record dbstruct testname) (if (and (< (- (current-seconds) *db:testmeta-last-update*) 600) (hash-table-exists? *db:testmeta-cache* testname)) (hash-table-ref *db:testmeta-cache* testname) (let ((res #f)) (db:with-db dbstruct #f #f (lambda (dbdat db) (sqlite3:for-each-row (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup) (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup))) db "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;" testname))) (hash-table-set! *db:testmeta-cache* testname res) (set! *db:testmeta-last-update* (current-seconds)) res))) ;; create a new record for a given testname (define (db:testmeta-add-record dbstruct testname) (db:with-db dbstruct #f #t (lambda (dbdat db) (sqlite3:execute db "INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname)))) ;; update one of the testmeta fields (define (db:testmeta-update-field dbstruct testname field value) (db:with-db dbstruct #f #t (lambda (dbdat db) (sqlite3:execute db (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname)))) (define (db:testmeta-get-all dbstruct) (db:with-db dbstruct #f #f (lambda (dbdat db) (let ((res '())) (sqlite3:for-each-row (lambda (a . b) (set! res (cons (apply vector a b) res))) db "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta;") res)))) |
︙ | ︙ | |||
4744 4745 4746 4747 4748 4749 4750 | (loop (car tal)(cdr tal) newr))))))) ;; the new prereqs calculation, looks also at itempath if specified ;; all prereqs must be met | | > | 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 | (loop (car tal)(cdr tal) newr))))))) ;; the new prereqs calculation, looks also at itempath if specified ;; all prereqs must be met ;; if prereq test with itempath='' is in common:well-ended-states, then prereq is met ;; if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met ;; ;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED) ;; mode 'toplevel means that tests must be COMPLETED only ;; mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]] ;; mode 'exclusive means this test/item cannot run if the same test/item is LAUNCHED,REMOTEHOSTSTART or RUNNING ;; ;; IDEA for consideration: ;; 1. collect all tests "upstream" ;; 2. any NOT completed and good? if yes => return those as prereqs not met, if no => return null list ;; ;; (define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode) (define (db:get-prereqs-not-met dbstruct run-id waitons ref-test-name ref-item-path mode itemmaps) ;; #!key (mode '(normal))(itemmap #f)) ;; BBnote - rollup of an itemized test's overall state/status done in db:set-state-status-and-roll-up-items (debug:print 4 *default-log-port* "db:get-prereqs-not-met: " waitons) (append (if (member 'exclusive mode) (let ((running-tests (db:get-tests-for-run dbstruct #f ;; run-id of #f means for all runs. (if (string=? ref-item-path "") ;; testpatt ref-test-name (conc ref-test-name "/" ref-item-path)) |
︙ | ︙ | |||
4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 | ;; (if (equal? (db:test-get-item-path testdat) "") ;; (db:test-get-testname testdat) ;; (conc (db:test-get-testname testdat) ;; "/" ;; (db:test-get-item-path testdat)))) running-tests) ;; calling functions want the entire data '()) ;; collection of: for each waiton - ;; if this ref-test-name is an item in an itemized test and mode is itemwait/itemmatch: ;; if waiton is not itemized - if waiton is not both completed and in ok status, add as unmet prerequisite ;; if waiton is itemized: ;; and waiton's items are not expanded, add as unmet prerequisite ;; else if matching waiton item is not both completed and in an ok status, add as unmet prerequisite | > > | 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 | ;; (if (equal? (db:test-get-item-path testdat) "") ;; (db:test-get-testname testdat) ;; (conc (db:test-get-testname testdat) ;; "/" ;; (db:test-get-item-path testdat)))) running-tests) ;; calling functions want the entire data '()) ;; collection of: for each waiton - ;; if this ref-test-name is an item in an itemized test and mode is itemwait/itemmatch: ;; if waiton is not itemized - if waiton is not both completed and in ok status, add as unmet prerequisite ;; if waiton is itemized: ;; and waiton's items are not expanded, add as unmet prerequisite ;; else if matching waiton item is not both completed and in an ok status, add as unmet prerequisite |
︙ | ︙ | |||
4911 4912 4913 4914 4915 4916 4917 | (set! result (append (if (null? waiton-tests)(list waitontest-name) waiton-tests) result)))))) waitons) (delete-duplicates result))))) ;;====================================================================== ;; To sync individual run ;;====================================================================== | | | < | < | | | | | > | | > | | < < < < > > > > > | | > > > > > > > > > > > > | > > > | > > > > > > | | | > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > | > > > | > > > > | | > > | | | 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 | (set! result (append (if (null? waiton-tests)(list waitontest-name) waiton-tests) result)))))) waitons) (delete-duplicates result))))) ;;====================================================================== ;; To sync individual run ;;====================================================================== (define (db:get-run-record-ids dbstruct target run keynames) (let* ((backcons (lambda (lst item)(cons item lst))) (all_tests '()) (keystr (string-intersperse (map (lambda (key val) (conc key " like '" val "'")) keynames (string-split target "/")) " AND ") ) (run-qry (conc "SELECT id FROM runs WHERE " keystr " and runname='" run"'")) ; (test-qry (conc "SELECT id FROM tests WHERE run_id in (" run-qry ") and testname like '" test-patt "'")) (run_ids (db:with-db dbstruct #f #f (lambda (dbdat db) (sqlite3:fold-row backcons '() db run-qry)) ) ) ) run_ids) ) ;;====================================================================== ;; Just for sync, procedures to make sync easy ;;====================================================================== ;; get an alist of run ids and test/run, test_step/run pairs changed since time since-time ;; '((runs . (1 2 3 ...))(tests . ((5 . 1) (6 . 3) (6 . 2) (7 . 1) ... ;; Retrieves record IDs from the database based on the timestamp of their last update. ;; The function takes two arguments: dbstruct, which represents the database structure, and since-time, which is a timestamp indicating the time of the last update. ;; The function first defines a few helper functions, including backcons, which takes a list and an item and adds the item to the front of the list. ;; It then initializes several variables to empty lists: all_tests, all_test_steps, all_test_data, all_run_ids, and all_test_ids. ;; The function then retrieves a list of IDs for runs that have been changed since since-time using the db:get-changed-run-ids function. ;; It then filters the full list of run IDs to only include those that match the changed run IDs based on their modulo (num-run-dbs). ;; For each changed run ID, the function retrieves a list of test IDs, test step IDs, and test data IDs that have been updated since since-time. ;; It appends these IDs to the appropriate lists (all_tests, all_test_steps, and all_test_data) using the append and map functions. ;; The function then retrieves a list of run stat IDs that have been updated since since-time. ;; Finally, the function returns a list of associations between record types and their corresponding IDs: runs, tests, test_steps, test_data, and run_stats. ;; (define (db:get-changed-record-ids dbstruct since-time) ;; no transaction, allow the db to be accessed between the big queries (let* ((backcons (lambda (lst item)(cons item lst))) (all_tests '()) (changed_run_dbs (db:get-changed-run-ids since-time)) ;; gets the rundb numbers (all_run_ids (db:with-db dbstruct #f #f (lambda (dbdat db) (sqlite3:fold-row backcons '() db "SELECT id FROM runs")) ) ) (changed_run_ids (filter (lambda (run) (member (modulo run (num-run-dbs)) changed_run_dbs)) all_run_ids)) (run_ids (db:with-db dbstruct #f #f (lambda (dbdat db) (sqlite3:fold-row backcons '() db "SELECT id FROM runs WHERE last_update>=?" since-time)) ) ) ) (for-each (lambda (run_id) (set! all_tests (append (map (lambda (x) (cons x run_id)) (db:with-db dbstruct run_id #f (lambda (dbdat db) (sqlite3:fold-row backcons '() db "SELECT id FROM tests WHERE run_id=? and last_update>=?" run_id since-time) ) ) ) all_tests ) ) ) changed_run_ids ) (debug:print 2 *default-log-port* "run_ids = " run_ids) (debug:print 2 *default-log-port* "all_tests = " all_tests) `((runs . ,run_ids) (tests . ,all_tests) ) ) ) (define (db:get-changed-record-test-ids dbstruct since-time run-id) (let* ((backcons (lambda (lst item)(cons item lst))) (all-tests (db:with-db dbstruct run-id #f (lambda (dbdat db) (sqlite3:fold-row backcons '() db "SELECT id FROM tests WHERE run_id=? and last_update>=?" run-id since-time))))) all-tests)) (define (db:get-changed-record-run-ids dbstruct since-time) ;; no transaction, allow the db to be accessed between the big queries (let* ((backcons (lambda (lst item)(cons item lst))) (run_ids (db:with-db dbstruct #f #f (lambda (dbdat db) (sqlite3:fold-row backcons '() db "SELECT id FROM runs WHERE last_update>=?" since-time))))) (debug:print 2 *default-log-port* "run_ids = " run_ids) run_ids) ) (define (db:get-all-runids dbstruct) (let* ((backcons (lambda (lst item)(cons item lst))) (all_run_ids (db:with-db dbstruct #f #f (lambda (dbdat db) (sqlite3:fold-row backcons '() db "SELECT id FROM runs"))))) all_run_ids)) ;;====================================================================== ;; Extract ods file from the db ;;====================================================================== ;; NOT REWRITTEN YET!!!!! ;; runspatt is a comma delimited list of run patterns ;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. ) (define (db:extract-ods-file dbstruct outputfile keypatt-alist runspatt pathmod) (assert #f "FATAL: call to db:extract-ods-file which is not ported yet.") (let* ((keysstr (string-intersperse (map car keypatt-alist) ",")) (keyqry (string-intersperse (map (lambda (p)(conc (car p) " LIKE ? ")) keypatt-alist) " AND ")) (numkeys (length keypatt-alist)) (test-ids '()) (dbdat (db:get-subdb dbstruct)) (db (dbr:dbdat-dbh dbdat)) (windows (and pathmod (substring-index "\\" pathmod))) (tempdir (conc "/tmp/" (current-user-name) "/" runspatt "_" (random 10000) "_" (current-process-id))) (runsheader (append (list "Run Id" "Runname") ; 0 1 (map car keypatt-alist) ; + N = length keypatt-alist (list "Testname" ; 2 "Item Path" ; 3 "Description" ; 4 |
︙ | ︙ | |||
5078 5079 5080 5081 5082 5083 5084 | (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path? outputfile (begin (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory") (conc (current-directory) "/" outputfile))) results) ;; brutal clean up | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 | (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path? outputfile (begin (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory") (conc (current-directory) "/" outputfile))) results) ;; brutal clean up (dbfile:add-dbdat dbstruct #f dbdat) (system "rm -rf tempdir"))) ;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%") ;;====================================================================== ;; moving watch dogs here due to dependencies ;;====================================================================== ;;====================================================================== ;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp ;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server) ;; (define (common:readonly-watchdog dbstruct) (thread-sleep! 0.05) ;; delay for startup (debug:print-info 13 *default-log-port* "common:readonly-watchdog entered.") ;; sync megatest.db to /tmp/.../megatst.db (let* ((sync-cool-off-duration 3) (golden-mtdb (dbr:dbstruct-mtdb dbstruct)) (golden-mtpath (db:dbdat-get-path golden-mtdb)) (tmp-mtdb (dbr:dbstruct-tmpdb dbstruct)) (tmp-mtpath (db:dbdat-get-path tmp-mtdb))) (debug:print-info 0 *default-log-port* "Read-only periodic sync thread started.") (let loop ((last-sync-time 0)) (debug:print-info 13 *default-log-port* "loop top tmp-mtpath="tmp-mtpath" golden-mtpath="golden-mtpath) (let* ((duration-since-last-sync (- (current-seconds) last-sync-time))) (debug:print-info 13 *default-log-port* "duration-since-last-sync="duration-since-last-sync) (if (and (not *time-to-exit*) (< duration-since-last-sync sync-cool-off-duration)) (thread-sleep! (- sync-cool-off-duration duration-since-last-sync))) (if (not *time-to-exit*) (let ((golden-mtdb-mtime (file-modification-time golden-mtpath)) (tmp-mtdb-mtime (file-modification-time tmp-mtpath))) (if (> golden-mtdb-mtime tmp-mtdb-mtime) (if (< golden-mtdb-mtime (- (current-seconds) 3)) ;; file has NOT been touched in past three seconds, this way multiple servers won't fight to sync back (let ((res (db:multi-db-sync dbstruct 'old2new))) (debug:print-info 13 *default-log-port* "rosync called, " res " records transferred.")))) (loop (current-seconds))) #t))) (debug:print-info 0 *default-log-port* "Exiting readonly-watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" mtpath="golden-mtpath))) ;; Get a lock from the no-sync-db for the from-db, then copy the from-db to the to-db, otherwise return #f (define (db:lock-and-sync no-sync-db from-db to-db) (assert (not *db-sync-in-progress*) "FATAL: db:lock-and-sync called while a sync is in progress.") (let* ((lockdat (db:no-sync-get-lock no-sync-db from-db)) (gotlock (car lockdat)) (locktime (cdr lockdat))) (if gotlock (begin (file-copy from-db to-db #t) (db:no-sync-del! no-sync-db from-db) #t) (begin (debug:print 0 *default-log-port* "could not get lock for " from-db " from no-sync-db") #f )))) ;; sync for filesystem local db writes ;; (define (db:run-lock-and-sync no-sync-db) (let* ((tmp-area (common:make-tmpdir-name *toppath* "")) (dbfiles (glob (conc tmp-area"/.mtdb/*.db"))) (sync-durations (make-hash-table))) ;; (debug:print-info 0 *default-log-port* "lock-and-sync, dbfiles: "dbfiles) (for-each (lambda (file) (let* ((fname (conc (pathname-file file) ".db")) (fulln (conc *toppath*"/.mtdb/"fname)) (time1 (if (file-exists? file) (file-modification-time file) (begin (debug:print-info 0 *default-log-port* "Sync - I do not see file "file) 1))) (time2 (if (file-exists? fulln) (file-modification-time fulln) (begin (debug:print-info 0 *default-log-port* "Sync - I do not see file "fulln) 0))) (changed (> time1 time2)) (do-cp (cond ((not (file-exists? fulln)) ;; shouldn't happen, but this might recover (debug:print-info 0 *default-log-port* "File "fulln" not found! Copying "fname" to "fulln) #t) (changed ;; (and changed ;; (> (- (current-seconds) time1) 3)) ;; if file is changed and three seconds have passed. #t) ((and changed *time-to-exit*) ;; last copy #t) (else #f)))) (if do-cp (let* ((start-time (current-milliseconds))) (debug:print-info 0 *default-log-port* "sync copy file: " fname", delta: " (- time1 time2) " seconds") (db:lock-and-sync no-sync-db file fulln) (hash-table-set! sync-durations (conc fname".db") (- (current-milliseconds) start-time))) #;(debug:print-info 0 *default-log-port* "skipping sync...")))) dbfiles) (hash-table->alist sync-durations))) ;; straight forward copy based sync ;; 1. for each .db fil ;; 2. next if file changed since last sync cycle ;; 2. next if time delta /tmp file to MTRA less than 3 seconds ;; 3. get a lock for the file in nosyncdb ;; 4. copy the file ;; 5. when copy is done release the lock ;; ;; DONE (define (server:writable-watchdog-copysync dbstruct) (thread-sleep! 0.05) ;; delay for startup (let ((legacy-sync (common:run-sync?)) (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300)) (debug-mode (debug:debug-mode 1)) (last-time (current-seconds)) ;; last time through the sync loop (no-sync-db (db:open-no-sync-db)) (sync-duration 0) ;; run time of the sync in milliseconds (tmp-area (common:make-tmpdir-name *toppath* ""))) ;; Sync moved to http-transport keep-running loop (debug:print-info 2 *default-log-port* "Periodic copy-based sync thread started. syncer is copy-sync, tmp-area is " tmp-area) (debug:print-info 3 *default-log-port* "watchdog starting. syncer is copy-sync pid="(current-process-id));; " this-wd-num="this-wd-num) (if (and legacy-sync (not *time-to-exit*)) (begin (debug:print-info 0 *default-log-port* "Server running, periodic copy-based sync started.") (let loop () ;; run the sync and print out durations (debug:print-info 0 *default-log-port* "Sync durations: "(db:run-lock-and-sync no-sync-db)) ;; keep going unless time to exit ;; (if (not *time-to-exit*) (let delay-loop ((count 0)) ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*) (if (and (not *time-to-exit*) (< count 6)) ;; was 11, changing to 4. (begin (thread-sleep! 1) (delay-loop (+ count 1)))) (if (not *time-to-exit*) (loop)))) ;; ==> ;; time to exit, close the no-sync db here ;; ==> (db:no-sync-close-db no-sync-db stmt-cache) (if (common:low-noise-print 30) (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id) ))))))) (define (server:writable-watchdog-deltasync dbstruct) ;; This is awful complex and convoluted. Plan to redo? ;; for now ... skip it. (thread-sleep! 0.05) ;; delay for startup (let ((legacy-sync (common:run-sync?))) (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300)) (debug-mode (debug:debug-mode 1)) (last-time (current-seconds)) (no-sync-db (db:open-no-sync-db)) (stmt-cache #f) ;; (dbr:dbstruct-stmt-cache dbstruct)) (sync-duration 0) ;; run time of the sync in milliseconds (subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct)))) (debug:print-info 2 *default-log-port* "Periodic sync thread started.") (debug:print-info 3 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id) );; " this-wd-num="this-wd-num) (if (and legacy-sync (not *time-to-exit*)) (begin (debug:print-info 0 *default-log-port* "Server running, periodic sync started.") (let loop () ;; sync for filesystem local db writes ;; (mutex-lock! *db-multi-sync-mutex*) (let* ((start-file (conc tmp-area "/.start-sync")) (end-file (conc tmp-area "/.end-sync")) (need-sync (>= *db-last-access* *db-last-sync*)) ;; no sync since last write (sync-in-progress *db-sync-in-progress*) (min-intersync-delay (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 5)) (should-sync (and (not *time-to-exit*) (> (- (current-seconds) *db-last-sync*) min-intersync-delay))) ;; sync every five seconds minimum, deprecated logic, can probably be removed (start-time (current-seconds)) (cpu-load-adj (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f))) (mt-mod-time (file-modification-time mtpath)) (last-sync-start (if (common:file-exists? start-file) (file-modification-time start-file) 0)) (last-sync-end (if (common:file-exists? end-file) (file-modification-time end-file) 10)) (sync-period (+ 3 (* cpu-load-adj 30))) ;; as adjusted load increases increase the sync period (recently-synced (and (< (- start-time mt-mod-time) sync-period) ;; not useful if sync didn't modify megatest.db! (< mt-mod-time last-sync-start))) (sync-done (<= last-sync-start last-sync-end)) (sync-stale (> start-time (+ last-sync-start sync-stale-seconds))) (will-sync (and (not *time-to-exit*) ;; do not start a sync if we are in the process of exiting (or need-sync should-sync) (or sync-done sync-stale) (not sync-in-progress) (not recently-synced)))) (debug:print-info 13 *default-log-port* "WD writable-watchdog top of loop. need-sync="need-sync" sync-in-progress=" sync-in-progress " should-sync="should-sync" start-time="start-time" mt-mod-time="mt-mod-time" recently-synced="recently-synced" will-sync="will-sync " sync-done=" sync-done " sync-period=" sync-period) (if (and (> sync-period 5) (common:low-noise-print 30 "sync-period")) (debug:print-info 0 *default-log-port* "Increased sync period due to long sync times, sync took: " sync-period " seconds.")) ;; (if recently-synced (debug:print-info 0 *default-log-port* "Skipping sync due to recently-synced flag=" recently-synced)) ;; (debug:print-info 0 *default-log-port* "need-sync: " need-sync " sync-in-progress: " sync-in-progress " should-sync: " should-sync " will-sync: " will-sync) (if will-sync (set! *db-sync-in-progress* #t)) (mutex-unlock! *db-multi-sync-mutex*) (if will-sync (let (;; (max-sync-duration (configf:lookup-number *configdat* "server" "max-sync-duration")) ;; KEEPING THIS AVAILABLE BUT SHOULD NOT USE, I'M PRETTY SURE IT DOES NOT WORK! (sync-start (current-milliseconds))) (with-output-to-file start-file (lambda ()(print (current-process-id)))) ;; put lock here ;; (if (or (not max-sync-duration) ;; (< sync-duration max-sync-duration)) ;; NOTE: db:sync-to-megatest.db keeps track of time of last sync and syncs incrementally ;; (for-each (lambda (subdb) (let* (;;(dbstruct (db:setup)) (mtdb (dbr:subdb-mtdb subdb)) (mtpath (db:dbdat-get-path mtdb)) (tmp-area (common:make-tmpdir-name *toppath* "")) (res (db:sync-to-megatest.db dbstruct no-sync-db: no-sync-db))) ;; did we sync any data? If so need to set the db touched flag to keep the server alive (set! sync-duration (- (current-milliseconds) sync-start)) (if (> res 0) ;; some records were transferred, keep the db alive (begin (mutex-lock! *heartbeat-mutex*) (set! *db-last-access* (current-seconds)) (mutex-unlock! *heartbeat-mutex*) (debug:print-info 0 *default-log-port* "sync called, " res " records transferred.")) (debug:print-info 2 *default-log-port* "sync called but zero records transferred"))) ) subdbs))) (if will-sync (begin (mutex-lock! *db-multi-sync-mutex*) (set! *db-sync-in-progress* #f) (set! *db-last-sync* start-time) (with-output-to-file end-file (lambda ()(print (current-process-id)))) ;; release lock here (mutex-unlock! *db-multi-sync-mutex*))) (if (and debug-mode (> (- start-time last-time) 60)) (begin (set! last-time start-time) (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*)))))) ;; keep going unless time to exit ;; (if (not *time-to-exit*) (let delay-loop ((count 0)) ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*) (if (and (not *time-to-exit*) (< count 6)) ;; was 11, changing to 4. (begin (thread-sleep! 1) (delay-loop (+ count 1)))) (if (not *time-to-exit*) (loop)))) ;; ;; time to exit, close the no-sync db here ;; (db:no-sync-close-db no-sync-db stmt-cache) (if (common:low-noise-print 30) (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id) )))) )) (define (std-exit-procedure) ;;(common:telemetry-log-close) (on-exit (lambda () 0)) ;; why is this here? ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*) (let ((no-hurry (if *time-to-exit* ;; hurry up #f (begin (set! *time-to-exit* #t) #t)))) (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.") (if (and no-hurry (debug:debug-mode 18)) (rmt:print-db-stats)) (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds (if *dbstruct-dbs* (db:close-all *dbstruct-dbs*)) ;; one second allocated (if (list? *on-exit-procs*) (for-each (lambda (proc) (proc)) *on-exit-procs*)) (if *task-db* (let ((db (cdr *task-db*))) (if (sqlite3:database? db) (begin (sqlite3:interrupt! db) (sqlite3:finalize! db #t) ;; (vector-set! *task-db* 0 #f) (set! *task-db* #f))))) (if (and *no-sync-db* (sqlite3:database? *no-sync-db*)) (sqlite3:finalize! *no-sync-db* #t)) (if (and (not (args:get-arg "-server")) *runremote* (eq? (rmt:transport-mode) 'http)) (begin (debug:print-info 0 *default-log-port* "Closing all client connections...") (http-transport:close-connections *runremote*) #;(http-client#close-all-connections!))) ;; (if (and *runremote* ;; (remote-conndat *runremote*)) ;; (begin ;; (http-client#close-all-connections!))) ;; for http-client (if (not (eq? *default-log-port* (current-error-port))) (close-output-port *default-log-port*)) (set! *default-log-port* (current-error-port))) "Cleanup db exit thread")) (th2 (make-thread (lambda () (debug:print 4 *default-log-port* "Attempting clean exit. Please be patient and wait a few seconds...") (if no-hurry (begin (thread-sleep! 5)) ;; give the clean up few seconds to do it's stuff (begin (thread-sleep! 2))) (debug:print 4 *default-log-port* " ... done") ) "clean exit"))) (thread-start! th1) (thread-start! th2) (thread-join! th1) ) ) 0) |
Modified db_records.scm from [37c233f08b] to [92d912cdd4].
︙ | ︙ | |||
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/>. ;;====================================================================== ;; dbstruct ;;====================================================================== | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== ;; dbstruct ;;====================================================================== (define (make-db:test)(make-vector 20)) (define-inline (db:test-get-id vec) (vector-ref vec 0)) (define-inline (db:test-get-run_id vec) (vector-ref vec 1)) (define-inline (db:test-get-testname vec) (vector-ref vec 2)) (define-inline (db:test-get-state vec) (vector-ref vec 3)) (define-inline (db:test-get-status vec) (vector-ref vec 4)) |
︙ | ︙ |
Added dbfile.scm version [32ab28635d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;;====================================================================== ;; 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/>. ;;====================================================================== (use srfi-18 posix hostinfo) (declare (unit dbfile)) (declare (uses debugprint)) (declare (uses commonmod)) (module dbfile * (import scheme) (cond-expand (chicken-4 (import chicken data-structures extras matchable (prefix sqlite3 sqlite3:) posix posix-extras typed-records srfi-18 srfi-1 srfi-69 stack files ports hostinfo commonmod debugprint ) ) (chicken-5 (import (prefix sqlite3 sqlite3:) ;; data-structures ;; extras ;; files ;; posix ;; posix-extras chicken.base chicken.condition chicken.file chicken.file.posix chicken.format chicken.io chicken.pathname chicken.port chicken.process chicken.process-context chicken.process-context.posix chicken.sort chicken.string chicken.time chicken.time.posix matchable md5 message-digest pathname-expand regex regex-case srfi-1 srfi-18 srfi-69 typed-records stack system-information commonmod debugprint ) (define file-write-access? file-writable?) (define file-move move-file) )) ;; parameters ;; (define dbfile:testsuite-name (make-parameter #f)) (define keep-age-param (make-parameter 10)) ;; qif file age, if over move to attic (define num-run-dbs (make-parameter 10)) ;; number of db's in .mtdb (define dbfile:sync-method (make-parameter 'attach)) ;; 'attach or 'original (define dbfile:cache-method (make-parameter 'cachedb)) ;; 'direct (define dbcache-mode (make-parameter 'tmp)) ;; 'cachedb, 'tmp (changes what open cachedb routine does) ;; moved from tcp-transportmod so that it can be used in launch.scm (define tt-server-profile-string (make-parameter "")) ;; 'original - use old condition code ;; 'suicide-mode - create mtrah/stop-the-train with info on what went wrong ;; else use no condition code (should be production mode) ;; (define no-condition-db-with-db (make-parameter 'suicide-mode)) ;;====================================================================== ;; R E C O R D S ;;====================================================================== ;; a single Megatest area with it's multiple dbs is ;; managed in a dbstruct ;; (defstruct dbr:dbstruct (areapath #f) (homehost #f) (tmppath #f) (read-only #f) (subdbs (make-hash-table)) ;; ;; for the cachedb approach (see dbmod.scm) ;; this is one db per server (cachedb #f) ;; handle for the in memory copy (dbfile #f) ;; path to the db file on disk (dbfname #f) ;; short name of db file on disk (used to validate accessing correct db) (ondiskdb #f) ;; handle for the on-disk file (dbtmpname #f) ;; path to db file in /tmp (non-imem method) (dbdat #f) ;; create a dbdat for the downstream calls such as db:with-db (last-update 0) (sync-proc #f) ) ;; NOTE: Need one dbr:subdb per main.db, 1.db ... ;; (defstruct dbr:subdb (dbname #f) ;; .mtdb/1.db (mtdbfile #f) ;; mtrah/.mtdb/1.db (mtdbdat #f) ;; only need one of these for syncing ;; (dbdats (make-hash-table)) ;; id => dbdat (tmpdbfile #f) ;; /tmp/.../.mtdb/1.db ;; (refndbfile #f) ;; /tmp/.../.mtdb/1.db_ref (dbstack (make-stack)) ;; stack for tmp dbr:dbdat, (homehost #f) ;; not used yet (on-homehost #f) ;; not used yet (read-only #f) (last-sync 0) (last-write (current-seconds)) ) ;; goal is to converge on one struct for an area but for now it is too confusing ;; need to keep dbhandles and cached statements together (defstruct dbr:dbdat (dbfile #f) (dbh #f) (stmt-cache (make-hash-table)) (read-only #f) (birth-sec (current-seconds))) ;; used in simple-get-runs (thanks Brandon!) (define-record simple-run target id runname state status owner event_time) (define-record-printer (simple-run x out) (fprintf out "#,(simple-run ~S ~S ~S ~S)" (simple-run-target x) (simple-run-id x) (simple-run-runname x) (time->string (seconds->local-time (simple-run-event_time x) )))) ;; args is hash table of string to value ;; (define (get-purpose args) (let* ((get-arg (lambda (key) (hash-table-ref/default args key #f))) (get-switch (lambda keys (fold (lambda (key res) (if (hash-table-ref/default args key #f) (or key res) res)) #f keys))) (action (get-switch "-server" "-execute" "-run" "-rerun"))) (cond (action (substring action 1 (string-length action))) (else "nopurpose")))) ;; megatest process tracking (defstruct procinf (start (current-seconds)) (end -1) (host (get-host-name)) ;; why is this not being recognised? (pid (current-process-id)) (port -1) (cwd (current-directory)) (load #f) (purpose #f) ;; get-purpose needed to be run in megatest.scm (dbname #f) (mtbin (car (argv))) (mtversion #f) (status "running") ) (define *procinf* (make-procinf)) (define *dbstruct-dbs* #f) (define *db-open-mutex* (make-mutex)) (define *db-access-mutex* (make-mutex)) ;; used in common.scm (define *no-sync-db* #f) (define *db-sync-in-progress* #f) (define *db-with-db-mutex* (make-mutex)) (define *max-api-process-requests* 0) (define *api-process-request-count* 0) (define *db-write-access* #t) (define *db-last-sync* 0) ;; last time the sync to megatest.db happened (define *db-multi-sync-mutex* (make-mutex)) ;; protect access to *db-sync-in-progress*, *db-last-sync* (define *db-last-access* (current-seconds)) (define *db-transaction-mutex* (make-mutex)) (define (db:generic-error-printout exn . message) (print-call-chain (current-error-port)) (apply dbfile:print-err message) (dbfile:print-err ", error: " ((condition-property-accessor 'exn 'message) exn) ", arguments: " ((condition-property-accessor 'exn 'arguments) exn) ", location: " ((condition-property-accessor 'exn 'location) exn) )) (define (dbfile:run-id->key run-id) (or run-id 'main)) (define (db:safely-close-sqlite3-db db stmt-cache #!key (try-num 3)) (if (<= try-num 0) #f (handle-exceptions exn (begin (print "Attempt to safely close sqlite3 db failed. Trying again. exn=" exn) (thread-sleep! 3) (sqlite3:interrupt! db) (db:safely-close-sqlite3-db db stmt-cache try-num: (- try-num 1))) (if (sqlite3:database? db) (let* ((stmts (and stmt-cache (hash-table-ref/default stmt-cache db #f)))) (if stmts (map sqlite3:finalize! (hash-table-values stmts))) (sqlite3:finalize! db) #t) (begin (dbfile:print-err "db:safely-close-sqlite3-db: " db " is not an sqlite3 db") #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) ", note - exn=" 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* ((subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct)))) (for-each (lambda (subdb) (let* ((tdbs (stack->list (dbr:subdb-dbstack subdb))) (mtdbdat (dbr:dbdat-dbh (dbr:subdb-mtdbdat subdb))) #;(rdb (dbr:dbdat-dbh (dbr:subdb-refndb subdb)))) (map (lambda (dbdat) (let* ((stmt-cache (dbr:dbdat-stmt-cache dbdat)) (dbh (dbr:dbdat-dbh dbdat))) (db:safely-close-sqlite3-db dbh stmt-cache))) tdbs) (db:safely-close-sqlite3-db mtdbdat (dbr:dbdat-stmt-cache (dbr:subdb-mtdbdat subdb))) ;; (if (sqlite3:database? mdb) (sqlite3:finalize! mdb)) #;(db:safely-close-sqlite3-db rdb #f))) ;; stmt-cache))))) ;; (if (sqlite3:database? rdb) (sqlite3:finalize! rdb)))))) subdbs) #t ) #f ) ) (define (dbfile:make-tmpdir-name areapath tmpadj) (let* ((area (pathname-file areapath)) (dname (conc "/tmp/"(current-user-name)"/megatest_localdb/" area "/" (string-translate areapath "/" ".") tmpadj "/.mtdb"))) (unless (directory-exists? dname) (create-directory dname #t)) dname)) (define (dbfile:run-id->path apath run-id) (conc apath"/"(dbfile:run-id->dbname run-id))) (define (db:dbname->path apath dbname) (conc apath"/"dbname)) (define (dbfile:run-id->dbnum run-id) (cond ((number? run-id) (modulo run-id (num-run-dbs))) ((not run-id) "main") ;; 0 or main? No, not 0. (else (assert #f "FATAL: run-id is required to be a number or #f")))) ;; just the filename (define (dbfile:run-id->dbfname run-id) (conc (dbfile:run-id->dbnum run-id)".db")) ;; the path in MTRAH with the filename (define (dbfile:run-id->dbname run-id) (conc (dbfile:run-id->dbfname run-id))) ;; Make the dbstruct, setup up auxillary db's and call for main db at least once ;; ;; called in http-transport and replicated in rmt.scm for *local* access. ;; (define (dbfile:setup areapath tmppath) (cond (*dbstruct-dbs* (dbfile:print-err "WARNING: dbfile:setup called when *dbstruct-dbs* is already initialized") *dbstruct-dbs*) ;; TODO: when multiple areas are supported, this optimization will be a hazard (else (let* ((dbstruct (make-dbr:dbstruct areapath: areapath tmppath: tmppath))) (set! *dbstruct-dbs* dbstruct) dbstruct)))) (define (dbfile:get-subdb dbstruct run-id) (let* ((dbfname (dbfile:run-id->dbname run-id))) (hash-table-ref/default (dbr:dbstruct-subdbs dbstruct) dbfname #f))) (define (dbfile:set-subdb dbstruct run-id subdb) (hash-table-set! (dbr:dbstruct-subdbs dbstruct) (dbfile:run-id->dbname run-id) subdb)) ;; (define *dbfile:num-handles-in-use* 0) ;; Get/open a database. ;; ;; NOTE: most usage should call dbfile:open-db to get a dbdat ;; ;; if run-id => get run specific db ;; if #f => get main db ;; if run-id is a string treat it as a filename - DON'T use this - we'll get rid of it. ;; if db already open - return cachedb ;; if db not open, open cachedb, rundb and sync then return cachedb ;; inuse gets set automatically for rundb's ;; (define (dbfile:get-dbdat dbstruct run-id) (let* ((subdb (dbfile:get-subdb dbstruct run-id))) (if (stack-empty? (dbr:subdb-dbstack subdb)) #f (begin (stack-pop! (dbr:subdb-dbstack subdb)))))) ;; return a previously opened db handle to the stack of available handles (define (dbfile:add-dbdat dbstruct run-id dbdat) (let* ((subdb (dbfile:get-subdb dbstruct run-id)) (dbstk (dbr:subdb-dbstack subdb)) (count (stack-count dbstk))) (if (> count 15) (dbfile:print-err "WARNING: stack for "run-id".db is "count".")) (stack-push! dbstk dbdat) dbdat)) ;; set up a subdb ;; (define (dbfile:init-subdb dbstruct run-id init-proc) (let* ((dbname (dbfile:run-id->dbname run-id)) (areapath (dbr:dbstruct-areapath dbstruct)) (tmppath (dbr:dbstruct-tmppath dbstruct)) (mtdbpath (dbfile:run-id->path areapath run-id)) (tmpdbpath (dbfile:run-id->path tmppath run-id)) (mtdbdat (dbfile:open-sqlite3-db mtdbpath init-proc sync-mode: 0 journal-mode: #f)) ;; "WAL")) (newsubdb (make-dbr:subdb dbname: dbname mtdbfile: mtdbpath tmpdbfile: tmpdbpath mtdbdat: mtdbdat))) (dbfile:set-subdb dbstruct run-id newsubdb) newsubdb)) ;; return the new subdb - but shouldn't really use it ;; returns dbdat with dbh and dbfilepath ;; ;; NOTE: the handle is on /tmp db file! ;; ;; 1. if needed setup the subdb for the given run-id ;; 2. if there is no existing db handle in the stack ;; create a new handle and return it (do NOT add ;; it to the stack). ;; (define (dbfile:open-db dbstruct run-id init-proc) (let* ((subdb (dbfile:get-subdb dbstruct run-id))) (if (not subdb) ;; not yet defined (begin (dbfile:init-subdb dbstruct run-id init-proc) (dbfile:open-db dbstruct run-id init-proc)) (let* ((dbdat (dbfile:get-dbdat dbstruct run-id))) (if dbdat dbdat (let* ((tmppath (dbr:dbstruct-tmppath dbstruct)) (tmpdbpath (dbfile:run-id->path tmppath run-id)) (dbdat (dbfile:open-sqlite3-db tmpdbpath init-proc sync-mode: 0 journal-mode: "WAL"))) ;; the following line short-circuits the "one db handle per thread" model ;; ;; (dbfile:add-dbdat dbstruct run-id dbdat) ;; dbdat)))))) ;; COMBINE dbfile:open-sqlite-db and dbfile:lock-create-open ;; ;; this stuff is for initial debugging, please remove it when ;; this code stabilizes (define *dbopens* (make-hash-table)) (define (dbfile:inc-db-open dbfile) (let* ((curr-opens-count (+ (hash-table-ref/default *dbopens* dbfile 0) 1))) (if (and (> curr-opens-count 1) ;; this should NOT be happening (common:low-noise-print 15 "db-opens")) (dbfile:print-err "INFO: db "dbfile" has been opened "curr-opens-count" times!")) (hash-table-set! *dbopens* dbfile curr-opens-count) curr-opens-count)) ;; Open the classic megatest.db file (defaults to open in toppath) ;; ;; NOTE: returns a dbdat not a dbstruct! ;; (define (dbfile:open-sqlite3-db dbpath init-proc #!key (sync-mode 0)(journal-mode #f)) (let* ((dbexists (file-exists? dbpath)) (write-access (file-write-access? dbpath)) (db (dbfile:cautious-open-database dbpath init-proc sync-mode journal-mode))) (dbfile:inc-db-open dbpath) ;; (init-proc db) (make-dbr:dbdat dbfile: dbpath dbh: db read-only: (not write-access)))) (define (dbfile:print-and-exit . params) (with-output-to-port (current-error-port) (lambda () (apply print params))) (exit 1)) (define (dbfile:print-err . params) (with-output-to-port (current-error-port) (lambda () (apply print params)))) (define (dbfile:cautious-open-database fname init-proc sync-mode journal-mode #!key (tries-left 500)(force-init #f)) (let* ((busy-file (conc fname "-journal")) (delay-time (* (- 51 tries-left) 1.1)) (write-access (file-write-access? fname)) (dir-access (file-write-access? (pathname-directory fname))) (retry (lambda () (thread-sleep! delay-time) (if (> tries-left 0) (dbfile:cautious-open-database fname init-proc sync-mode journal-mode tries-left: (- tries-left 1)))))) (assert (>= tries-left 0) (conc "FATAL: too many attempts in dbfile:cautious-open-database of "fname", giving up.")) (if (and (file-write-access? fname) (file-exists? busy-file)) (begin (if (common:low-noise-print 120 busy-file) (dbfile:print-err "INFO: dbfile:cautious-open-database: journal file " busy-file" exists, trying again in few seconds.")) (thread-sleep! 1) (if (eq? tries-left 2) (begin (dbfile:print-err "INFO: forcing journal rollup "busy-file) (dbfile:brute-force-salvage-db fname))) (dbfile:cautious-open-database fname init-proc sync-mode journal-mode tries-left: (- tries-left 1))) (let* ((result (condition-case (if dir-access (dbfile:with-simple-file-lock (conc fname ".lock") (lambda () (let* ((db-exists (file-exists? fname)) (db (sqlite3:open-database fname))) ;; creates an empty db if it did not already exist. (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 30000)) (if sync-mode (sqlite3:execute db (conc "PRAGMA synchronous = "sync-mode";"))) (if journal-mode (sqlite3:execute db (conc "PRAGMA journal_mode = "journal-mode";"))) (if (and init-proc (or force-init (not db-exists))) (init-proc db)) db)) expire-time: 30) (begin (if (file-exists? fname ) (let ((db (sqlite3:open-database fname))) ;; pragmas synchronous not needed because this db is used read-only ;; (sqlite3:execute db (conc "PRAGMA synchronous = "mode";") (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 30000)) ;; read-only but still need timeout db ) (print "cautious-open-database: file doesn't exist: " fname)))) (exn (io-error) (dbfile:print-err exn "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.") (retry)) (exn (corrupt) (dbfile:print-err exn "ERROR: database " fname " is corrupt. Repair it to proceed.") (retry)) (exn (busy) (dbfile:print-err exn "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back.") (retry)) (exn (permission)(dbfile:print-err exn "ERROR: database " fname " has some permissions problem.") (retry)) (exn () (dbfile:print-err exn "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn)) (retry))))) result)))) (define (dbfile:brute-force-salvage-db fname) (let* ((backupfname (conc fname"-"(current-process-id)".bak")) (cmd (conc "cp "fname" "backupfname";mv "fname" "(conc fname ".delme;") "cp "backupfname" "fname))) (dbfile:print-err "WARNING: attempting recovery of file "fname" by running commands:\n" " "cmd) (system cmd))) ;; opens and returns handle and nothing else ;; ;; NOTE: this is already protected by mutex *no-sync-db-mutex* ;; (define (dbfile:raw-open-no-sync-db dbpath) (if (not (file-exists? dbpath)) (create-directory dbpath #t)) (debug:print-info 2 *default-log-port* "(dbfile:raw-open-no-sync-db: Opening "dbpath"/no-sync.db") (let* ((dbname (conc dbpath "/no-sync.db")) (db-exists (file-exists? dbname)) (init-proc (lambda (db) (sqlite3:with-transaction db (lambda () ;; I have been having trouble with init of no-sync.db so ;; doing the init in a transaction every time (no gating ;; on file existance. (for-each (lambda (stmt) (sqlite3:execute db stmt)) (list "CREATE TABLE IF NOT EXISTS jobs_queue (id INTEGER PRIMARY KEY, host_type TEXT, cores INTEGER, memory TEXT, vars TEXT, exekey TEXT, cmdline TEXT, state TEXT, event_time INTEGER, last_update INTEGER);" "CREATE TABLE IF NOT EXISTS test_extra_data (id INTEGER PRIMARY KEY, run_id INTEGER, test_id INTEGER, last_seen_running INTEGER);" "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT, val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));" "CREATE TABLE IF NOT EXISTS no_sync_locks (key TEXT, val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (key));" "CREATE TABLE IF NOT EXISTS processes (id INTEGER PRIMARY KEY, host TEXT, port INTEGER, pid INTEGER, starttime INTEGER, endtime INTEGER, status TEXT, purpose TEXT, dbname TEXT, mtversion TEXT, reason TEXT DEFAULT 'none', CONSTRAINT no_sync_processes UNIQUE (host,pid));" )))))) (on-tmp (equal? (car (string-split dbpath "/")) "tmp")) (db (if on-tmp (dbfile:cautious-open-database dbname init-proc 1 "WAL" force-init: #t) ;; WAL MODE should use syncronous=1 ;; (dbfile:cautious-open-database dbname init-proc 0 #f force-init: #t) (dbfile:cautious-open-database dbname init-proc 0 "MEMORY" force-init: #t) ;; Journal mode = memory is fastest? ;; (sqlite3:open-database dbname) ))) ;; (if on-tmp ;; done in cautious-open-database ;; (begin ;; (sqlite3:execute db "PRAGMA synchronous = 0;") ;; why was this here when is is handled by cautious-open-database? (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) ;; )) db)) ;; mtest processes registry calls (define (dbfile:insert-or-update-process nsdb dat) (let* ((host (procinf-host dat)) (pid (procinf-pid dat)) (curr-info (dbfile:get-process-info nsdb host pid))) (if curr-info ;; record exists, do update (match curr-info ((host port pid starttime endtime status purpose dbname mtversion) (sqlite3:execute nsdb "UPDATE processes SET port=?,starttime=?,endtime=?,status=?, purpose=?,dbname=?,mtversion=? WHERE host=? AND pid=?;" (or (procinf-port dat) port) (or (procinf-start dat) starttime) (or (procinf-end dat) endtime) (or (procinf-status dat) status) (or (procinf-purpose dat) purpose) (or (procinf-dbname dat) dbname) (or (procinf-mtversion dat) mtversion) host pid)) (else #f ;; what to do? )) (dbfile:register-process nsdb (procinf-host dat) (procinf-port dat) (procinf-pid dat) (procinf-start dat) (procinf-end dat) (procinf-status dat) (procinf-purpose dat) (procinf-dbname dat) (procinf-mtversion dat))))) (define (dbfile:register-process nsdb host port pid starttime endtime status purpose dbname mtversion) (sqlite3:execute nsdb "INSERT INTO processes (host,port,pid,starttime,endtime,status,purpose,dbname,mtversion) VALUES (?,?,?,?,?,?,?,?,?);" host port pid starttime endtime status purpose dbname mtversion)) (define (dbfile:set-process-status nsdb host pid newstatus) (sqlite3:execute nsdb "UPDATE processes SET status=? WHERE host=? AND pid=?;" newstatus host pid)) ;; as sorted should be stable. can use to choose "winner" ;; (define (dbfile:get-process-options nsdb purpose dbname) (sqlite3:fold-row ;; host port pid starttime status mtversion (lambda (res . row) (cons row res)) '() nsdb "SELECT host,port,pid,starttime,endtime,status,mtversion FROM processes WHERE purpose=? AND dbname LIKE ? AND status IN ('running','alive') ORDER BY starttime ASC,host,port;" purpose dbname)) (define (dbfile:get-process-info nsdb host pid) (let ((res (sqlite3:fold-row ;; host port pid starttime status mtversion (lambda (res . row) (cons row res)) '() nsdb "SELECT host,port,pid,starttime,endtime,status,purpose,dbname,mtversion FROM processes WHERE host=? AND pid=?;" host pid))) (if (null? res) #f (car res)))) (define (dbfile:row->procinf row) (match row ((host port pid starttime endtime status mtversion) (make-procinf host: host port: port pid: pid starttime: starttime endtime: endtime status: status mtversion: mtversion)) (else (debug:print 0 *default-log-port* "ERROR: row "row" did not match host,port,pid,starttime,endtime,status,mtversion") #f))) (define (dbfile:set-process-done nsdb host pid reason) (sqlite3:execute nsdb "UPDATE processes SET status='done',endtime=?,reason=? WHERE host=? AND pid=?;" (current-seconds) reason host pid) (dbfile:cleanup-old-entries nsdb)) (define (dbfile:cleanup-old-entries nsdb) (sqlite3:execute nsdb "DELETE FROM process WHERE status='done' AND endtime<?;" (- (current-seconds) (* 3600 48)))) ;; other no-sync functions (define (dbfile:with-no-sync-db dbpath proc) (mutex-lock! *no-sync-db-mutex*) (let* ((already-open *no-sync-db*) (db (or already-open (dbfile:raw-open-no-sync-db dbpath))) (res (proc db))) (if (not already-open) (sqlite3:finalize! db)) (mutex-unlock! *no-sync-db-mutex*) res)) (define *no-sync-db-mutex* (make-mutex)) (define (dbfile:open-no-sync-db dbpath) (mutex-lock! *no-sync-db-mutex*) (let* ((res (if *no-sync-db* *no-sync-db* (let* ((db (dbfile:raw-open-no-sync-db dbpath))) (set! *no-sync-db* db) db)))) (mutex-unlock! *no-sync-db-mutex*) res)) (define (db:no-sync-set db var val) (sqlite3:execute db "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES (?,?);" var val)) (define (db:no-sync-del! db var) (sqlite3:execute db "DELETE FROM no_sync_metadat WHERE var=?;" var)) (define (db:no-sync-get/default db var default) (assert (sqlite3:database? db) "FATAL: db:no-sync-get/default called with a bad db handle:" db) (let ((res default)) (sqlite3:for-each-row (lambda (val) (set! res val)) db "SELECT val FROM no_sync_metadat WHERE var=?;" var) (if res (let ((newres (if (string? res) (string->number res) #f))) (if newres newres res)) res))) ;; timestring+identifier+payload ;; locks are unique on identifier, payload is informational (define (db:extract-time-identifier instr) (let ((tokens (string-split instr "+"))) (match tokens ((t i)(cons (string->number t) i)) ((t) (cons (string->number t) #f)) (else (assert #f "FATAL: db:extract-time-identifier handed bad data "instr))))) ;; transaction protected lock aquisition ;; either: ;; fails returns (#f lock-creation-time identifier) ;; succeeds (returns (#t lock-creation-time identifier) ;; use (db:no-sync-del! db keyname) to release the lock ;; (define (db:no-sync-get-lock-with-id db keyname identifier) (debug:print 2 *default-log-port* "db:no-sync-get-lock-with-id: db: " db " keyname: " keyname " identifier: " identifier) (sqlite3:with-transaction db (lambda () (condition-case (let* ((curr-val (db:no-sync-get/default db keyname #f))) (debug:print 2 *default-log-port* "db:no-sync-get-lock-with-id: curr-val: " curr-val) (if curr-val (match (db:extract-time-identifier curr-val) ;; result->timestamp, identifier ((timestamp . ident) (cons (equal? ident identifier) timestamp)) (else (debug:print 2 *default-log-port* "db:no-sync-get-lock-with-id: malformed lock") (cons #f 'malformed-lock) ) ) ;; lock malformed (let ((curr-sec (current-seconds)) (lock-value (if identifier (conc (current-seconds)"+"identifier) (current-seconds)))) (sqlite3:execute db "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES(?,?);" keyname lock-value) (cons #t curr-sec)))) (exn (io-error) (dbfile:print-err "ERROR: i/o error with no-sync db. Check permissions, disk space etc. and try again.")) (exn (corrupt) (dbfile:print-err "ERROR: database no-sync db is corrupt. Repair it to proceed.")) (exn (busy) (dbfile:print-err "ERROR: database no-sync db is locked. Try copying to another location, remove original and copy back.")) (exn (permission)(dbfile:print-err "ERROR: database no-sync db has some permissions problem.")) (exn () ;; (status done) ;; I don't know how to detect status done but no data! (dbfile:print-err "ERROR: Unknown error with database no-sync db message: exn="(condition->list exn)", \n" ((condition-property-accessor 'exn 'message) exn)) (cons #f #f)))))) (define (db:no-sync-check-lock db keyname identifier) (let* ((curr-val (db:no-sync-get/default db keyname #f))) (match (db:extract-time-identifier curr-val) ;; result->timestamp, identifier ((timestamp . ident) (cons (equal? ident identifier) ident)) (else (cons #f 'no-lock))))) ;; get the lock, wait 0.25 seconds and verify still have it. ;; this should not be necessary given the use of transaction in ;; db:no-sync-get-lock-with-id but it does seem to be needed ;; (define (db:no-sync-lock-and-check db keyname identifier) (let* ((result (db:no-sync-get-lock-with-id db keyname identifier)) (gotlock (car result))) (if gotlock (begin (thread-sleep! 0.25) (db:no-sync-check-lock db keyname identifier)) result))) ;; transaction protected lock aquisition ;; either: ;; fails returns (#f . lock-creation-time) ;; succeeds (returns (#t . lock-creation-time) ;; use (db:no-sync-del! db keyname) to release the lock ;; (define (db:no-sync-get-lock db keyname) (sqlite3:with-transaction db (lambda () (condition-case (let* ((curr-val (db:no-sync-get/default db keyname #f))) (if curr-val `(#f . ,curr-val) ;; (sqlite3:first-result db "SELECT val FROM no_sync_metadat WHERE var=?;" keyname)) (let ((lock-time (current-seconds))) (sqlite3:execute db "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES(?,?);" keyname lock-time) `(#t . ,lock-time)))) (exn (io-error) (dbfile:print-err "ERROR: i/o error with no-sync db. Check permissions, disk space etc. and try again.")) (exn (corrupt) (dbfile:print-err "ERROR: database no-sync db is corrupt. Repair it to proceed.")) (exn (busy) (dbfile:print-err "ERROR: database no-sync db is locked. Try copying to another location, remove original and copy back.")) (exn (permission)(dbfile:print-err "ERROR: database no-sync db has some permissions problem.")) (exn () ;; (status done) ;; I don't know how to detect status done but no data! (dbfile:print-err "ERROR: Unknown error with database no-sync db message: exn="(condition->list exn)", \n" ((condition-property-accessor 'exn 'message) exn)) `(#f . ,(current-seconds))))))) (define (db:no-sync-get-lock-timeout db keyname timeout) (let* ((lockdat (db:no-sync-get-lock db keyname))) (match lockdat ((#f . lock-time) (if (> (- (current-seconds) (if (string? lock-time)(string->number lock-time)lock-time)) timeout) (let ((lock-time (current-seconds))) ;; (debug:print-info 2 *default-log-port* "db:no-sync-get-lock keyname=" keyname ", lock-time=" lock-time ", exn=" exn) (sqlite3:execute db "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES(?,?);" keyname lock-time) `(#t . ,lock-time)) lockdat)) (else lockdat)))) ;; NOTE: This will steal the lock after timeout of waiting. ;; (define (db:with-no-sync-lock db keyname timeout proc) (let* ((lockdat (db:no-sync-get-lock-timeout db keyname)) (gotlock (car lockdat)) (locktime (cdr lockdat))) (if gotlock (let ((res (proc))) (db:no-sync-del! db keyname) res)))) ;;====================================================================== ;; sync back functions pulled from db.scm ;;====================================================================== ;; Get a lock from the no-sync-db for the from-db, then delta sync the from-db to the to-db, otherwise return #f ;; (define (db:lock-and-delta-sync no-sync-db dbstruct from-db-file runid keys dbinit) (assert (not *db-sync-in-progress*) "FATAL: db:lock-and-sync called while a sync is in progress.") ;; (dbfile:print-err *default-log-port* "db:lock-and-delta-sync") (let* ((lock-file (conc from-db-file ".lock"))) (if (common:simple-file-lock lock-file) (begin (dbfile:print-err "INFO: db:lock-and-delta-sync copying db "runid" at "(current-seconds)) (set! *db-sync-in-progress* #t) (db:sync-touched dbstruct runid keys dbinit) (set! *db-sync-in-progress* #f) (delete-file* lock-file) #t) (begin (if (common:low-noise-print 120 (conc "no lock "from-db-file)) (dbfile:print-err "INFO: could not get lock for " from-db-file ", sync likely in progress.")) #f )))) ;; ;; Get a lock from the no-sync-db for the from-db, then delta sync the from-db to the to-db, otherwise return #f ;; ;; ;; (define (db:lock-and-delta-sync-orig no-sync-db dbstruct from-db-file runid keys dbinit) ;; (assert (not *db-sync-in-progress*) "FATAL: db:lock-and-sync called while a sync is in progress.") ;; ;; (dbfile:print-err *default-log-port* "db:lock-and-delta-sync") ;; (let* ((lockdat (db:no-sync-get-lock-timeout no-sync-db from-db-file 60)) ;; (gotlock (car lockdat)) ;; (locktime (cdr lockdat))) ;; ;; (debug:print-info 3 *default-log-port* "db:lock-and-delta-sync: got lock?") ;; ;; (if gotlock ;; (begin ;; (dbfile:print-err "INFO: db:lock-and-delta-sync copying db "runid" at "(current-seconds)) ;; (set! *db-sync-in-progress* #t) ;; (db:sync-touched dbstruct runid keys dbinit) ;; (set! *db-sync-in-progress* #f) ;; (db:no-sync-del! no-sync-db from-db-file) ;; #t) ;; (begin ;; (dbfile:print-err "ERROR: could not get lock for " from-db-file " from no-sync-db") ;; #f ;; )))) ;; sync run from tmp disk to nfs disk if touched ;; ;; call with dbinit=db:initialize-main-db ;; (define (db:sync-touched dbstruct run-id keys #!key dbinit (force-sync #f)) (dbfile:print-err "db:sync-touched Syncing: " (conc (if run-id run-id "main") ".db")) (let* (;; the subdb is needed to access the mtdbdat (subdb (or (dbfile:get-subdb dbstruct run-id) (dbfile:init-subdb dbstruct run-id dbinit))) (tmpdbfile (dbr:subdb-tmpdbfile subdb)) (mtdb (dbr:subdb-mtdbdat subdb)) (tmpdb (db:open-db dbstruct run-id dbinit)) ;; sqlite3-db tmpdbfile #f)) (start-t (current-seconds))) (mutex-lock! *db-multi-sync-mutex*) (let ((update_info (cons "last_update" (if force-sync 0 *db-last-sync*) ))) (mutex-unlock! *db-multi-sync-mutex*) (db:sync-tables (db:sync-all-tables-list keys) update_info tmpdb 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*) (dbfile:add-dbdat dbstruct run-id tmpdb) #t)) ;; just tests, test_steps and test_data tables (define db:sync-tests-only (list ;; (list "strs" ;; '("id" #f) ;; '("str" #f)) (list "tests" '("id" #f) '("run_id" #f) '("testname" #f) '("host" #f) '("cpuload" #f) '("diskfree" #f) '("uname" #f) '("rundir" #f) '("shortdir" #f) '("item_path" #f) '("state" #f) '("status" #f) '("attemptnum" #f) '("final_logf" #f) '("logdat" #f) '("run_duration" #f) '("comment" #f) '("event_time" #f) '("fail_count" #f) '("pass_count" #f) '("archived" #f) '("last_update" #f)) (list "test_steps" '("id" #f) '("test_id" #f) '("stepname" #f) '("state" #f) '("status" #f) '("event_time" #f) '("comment" #f) '("logfile" #f) '("last_update" #f)) (list "test_data" '("id" #f) '("test_id" #f) '("category" #f) '("variable" #f) '("value" #f) '("expected" #f) '("tol" #f) '("units" #f) '("comment" #f) '("status" #f) '("type" #f) '("last_update" #f)))) ;; needs db to get keys, this is for syncing all tables ;; (define (db:sync-main-list keys) (let ((keys keys)) (list (list "keys" '("id" #f) '("fieldname" #f) '("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) '("avg_runtime" #f) '("avg_disk" #f) '("tags" #f) '("jobgroup" #f)) (list "tasks_queue" '("id" #f) '("action" #f) '("owner" #f) '("state" #f) '("target" #f) '("name" #f) '("testpatt" #f) '("keylock" #f) '("params" #f) '("creation_time" #f) '("execution_time" #f)) ))) (define (db:sync-all-tables-list keys) (append (db:sync-main-list keys) db:sync-tests-only)) ;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) ;; db's are dbdat's ;; ;; if last-update specified ("field-name" . time-in-seconds) ;; then sync only records where field-name >= time-in-seconds ;; IFF field-name exists ;; (define (db:sync-tables tbls last-update fromdb todb . slave-dbs) (handle-exceptions exn (begin (dbfile:print-err "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.") (print-call-chain (current-error-port)) (dbfile:print-err " message: " ((condition-property-accessor 'exn 'message) exn)) (dbfile:print-err "exn=" (condition->list exn)) (dbfile:print-err " status: " ((condition-property-accessor 'sqlite3 'status) exn)) (dbfile:print-err " src db: " (dbr:dbdat-dbfile fromdb)) (for-each (lambda (dbdat) (let ((dbpath (dbr:dbdat-dbfile dbdat))) (dbfile:print-err " dbpath: " dbpath) (if #t ;; (not (db:repair-db dbdat)) (begin (dbfile:print-err "Failed to rebuild (repair is turned off) " dbpath ", exiting now.") (exit))))) (cons todb slave-dbs)) 0) ;; this is the work to be done") (cond ((not fromdb) (dbfile:print-err "WARNING: db:sync-tables called with fromdb missing") -1) ((not todb) (dbfile:print-err "WARNING: db:sync-tables called with todb missing") -2) ((not (sqlite3:database? (dbr:dbdat-dbh fromdb))) (dbfile:print-err "db:sync-tables called with fromdb not a database " fromdb) -3) ((not (sqlite3:database? (dbr:dbdat-dbh todb))) (dbfile:print-err "db:sync-tables called with todb not a database " todb) -4) ((not (file-write-access? (dbr:dbdat-dbfile todb))) (dbfile:print-err "db:sync-tables called with todb not a read-only database " todb) -5) ((not (null? (let ((readonly-slave-dbs (filter (lambda (dbdat) (not (file-write-access? (dbr:dbdat-dbfile todb)))) slave-dbs))) (for-each (lambda (bad-dbdat) (dbfile:print-err "db:sync-tables called with todb not a read-only database " bad-dbdat)) readonly-slave-dbs) readonly-slave-dbs))) -6) (else ;; (dbfile:print-err "db:sync-tables: args are good") (let ((stmts (make-hash-table)) ;; table-field => stmt (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 )) (numrecs (make-hash-table)) (start-time (current-milliseconds)) (tot-count 0)) (for-each ;; table (lambda (tabledat) (let* ((tablename (car tabledat)) (fields (cdr tabledat)) (has-last-update (member "last_update" fields)) (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) ((and last-update (not (pair? last-update)) (not (number? last-update))) (dbfile:print-err "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)) #f)) (last-update-field (if use-last-update (if (number? last-update) "last_update" (car last-update)) #f)) (num-fields (length fields)) (field->num (make-hash-table)) (num->field (apply vector (map car fields))) ;; BBHERE (full-sel (conc "SELECT " (string-intersperse (map car fields) ",") " FROM " tablename (if use-last-update ;; apply last-update criteria (conc " WHERE " last-update-field " >= " last-update-value) "") ";")) (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) " " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );")) (fromdat '()) (fromdats '()) (totrecords 0) (batch-len 100) ;; (string->number (or (configf:lookup *configdat* "sync" "batchsize") "100"))) (todat (make-hash-table)) (count 0) (field-names (map car fields)) (delay-handicap 0) ;; (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) (set! count (+ count 1))) fields) ;; read the source table ;; store a list of all rows in the table in fromdat, up to batch-len. ;; Then add fromdat to the fromdats list, clear fromdat and repeat. (sqlite3:with-transaction (dbr:dbdat-dbh fromdb) (lambda () (sqlite3:for-each-row (lambda (a . b) (set! fromdat (cons (apply vector a b) fromdat)) (if (> (length fromdat) batch-len) (begin (set! fromdats (cons fromdat fromdats)) (set! fromdat '()) (set! totrecords (+ totrecords 1))) ) ) (dbr:dbdat-dbh fromdb) full-sel) ) ) ;; Count less than batch-len as a record (if (> (length fromdat) 0) (set! totrecords (+ totrecords 1))) ;; tack on remaining records in fromdat (if (not (null? fromdat)) (set! fromdats (cons fromdat fromdats))) (sqlite3:for-each-row (lambda (a . b) (hash-table-set! todat a (apply vector a b))) (dbr:dbdat-dbh todb) full-sel) (when (and delay-handicap (> delay-handicap 0)) (dbfile:print-err "imposing synthetic sync delay of "delay-handicap" seconds since sync/delay-handicap is configured") (thread-sleep! delay-handicap) (dbfile:print-err "synthetic sync delay of "delay-handicap" seconds completed") ) ;; first pass implementation, just insert all changed rows (for-each (lambda (targdb) (let* ((db (dbr:dbdat-dbh targdb)) (drp-trigger (if (member "last_update" field-names) (db:drop-trigger db tablename) #f)) (has-last-update (member "last_update" field-names)) (is-trigger-dropped (if has-last-update (db:is-trigger-dropped db tablename) #f)) (stmth (sqlite3:prepare db full-ins)) (changed-rows 0)) (for-each (lambda (fromdat-lst) (sqlite3:with-transaction db (lambda () (for-each ;; (lambda (fromrow) (let* ((a (vector-ref fromrow 0)) (curr (hash-table-ref/default todat a #f)) (same #t)) (let loop ((i 0)) (if (or (not curr) (not (equal? (vector-ref fromrow i)(vector-ref curr i)))) (set! same #f)) (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))) (set! changed-rows (+ changed-rows 1)) ) ) )) 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. (for-each (lambda (dat) (let ((tblname (car dat)) (count (cdr dat))) (set! tot-count (+ tot-count count)) )) (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))) tot-count))))) ;;====================================================================== ;; trigger setup/takedown ;;====================================================================== (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:is-trigger-dropped db tbl-name) (let* ((trigger-name (if (equal? tbl-name "test_steps") "update_teststeps_trigger" (conc "update_" tbl-name "_trigger"))) (res #f)) (sqlite3:for-each-row (lambda (name) (if (equal? name trigger-name) (set! res #t))) db "SELECT name FROM sqlite_master WHERE type = 'trigger' ;") res)) (define (db:drop-triggers db) (for-each (lambda (key) (sqlite3:execute db (conc "drop trigger if exists " (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 if exists " 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))) ;;====================================================================== ;; db access stuff ;;====================================================================== ;; call with dbinit=db:initialize-main-db ;; (define (db:open-db dbstruct run-id dbinit) ;; (mutex-lock! *db-open-mutex*) (let* ((dbdat (dbfile:open-db dbstruct run-id dbinit))) (set! *db-write-access* (not (dbr:dbdat-read-only dbdat))) ;; (mutex-unlock! *db-open-mutex*) dbdat)) (define dbfile:db-init-proc (make-parameter #f)) ;; in xmaxima this gives a curve close to what I want: ;; plot2d ((exp(x/1.2)-1)/300, [x, 0, 10])$ ;; plot2d ((exp(x/1.5)-1)/40, [x, 0, 10])$ ;; plot2d ((exp(x/5)-1)/40, [x, 0, 20])$ (define (dbfile:droop x) (/ (- (exp (/ x 5)) 1) 40)) ;; (* numqrys (/ 1 (qif-slope)))) ;; create a dropping near the db file in a qif dir ;; use count of such files to gate queries (queries in flight) ;; (define (dbfile:wait-for-qif fname run-id params) (let* ((thedir (pathname-directory fname)) (dbnum (dbfile:run-id->dbnum run-id)) (destdir (conc thedir"/qif-"dbnum)) (uniqn (get-area-path-signature (conc dbnum params))) (crumbn (conc destdir"/"(current-seconds)"-"uniqn"."(current-process-id)))) (if (not (file-exists? destdir))(create-directory (conc destdir"/attic") #t)) (let loop ((count 0)) (let* ((currlks (glob (conc destdir"/*"))) (numqrys (length currlks)) (delayval (cond ;; do a droopish curve ((> numqrys 25) (for-each (lambda (f) (if (> (- (current-seconds) (handle-exceptions exn (current-seconds) ;; file is likely gone, just fake out (file-modification-time f))) (keep-age-param)) (let* ((basedir (pathname-directory f)) (filen (pathname-file f)) (destf (conc basedir"/attic/"filen))) (dbfile:print-err "Moving qif file "f" older than 10 seconds to "destf) ;; (delete-file* f) (handle-exceptions exn #t (file-move f destf #t))))) currlks) 4) ((> numqrys 0) (dbfile:droop numqrys)) ;; slope of 1/100 (else #f)))) (if (and delayval (< count 5)) (begin (thread-sleep! delayval) (loop (+ count 1)))))) (with-output-to-file crumbn (lambda () (print fname" run-id="run-id" params="params) )) crumbn)) ;; ;; (db:with-db dbstruct run-id sqlite3:exec "select blah fgrom blaz;") ;; ;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no ;; ;; ;; ;; Used only with http - to be removed ;; ;; ;; (define (dbfile:with-db dbstruct run-id r/w proc params) ;; (assert dbstruct "FATAL: db:with-db called with dbstruct "#f) ;; (assert (dbr:dbstruct? dbstruct) "FATAL: dbstruct is "dbstruct) ;; ;; Testing 2023, March 14th. I went from full time use of the mutext to no use at all and ;; ;; didn't see much change in the frequency of the messages: ;; ;; Warning (#<thread: thread14974>): in thread: (bind!) bad parameter or other API misuse ;; ;; allowing request count to go up to 1000 and other crashes showed up: ;; ;; Warning (#<thread: thread1889>): in thread: (deserialize) unexpected end of input: #<input port "(tcp)"> ;; ;; ;; ;; leave it fully on for now, test later if there is a performance issue ;; ;; ;; (let* ((use-mutex #t) ;;(> *api-process-request-count* 50)) ;; risk of db corruption ;; (have-struct (dbr:dbstruct? dbstruct)) ;; (dbdat (if have-struct ;; this stuff just allows us to call with a db handle directly ;; (db:open-db dbstruct run-id (dbfile:db-init-proc)) ;; (dbfile:get-subdb dbstruct run-id) ;; #f)) ;; (db (if have-struct ;; this stuff just allows us to call with a db handle directly ;; (dbr:dbdat-dbh dbdat) ;; dbstruct)) ;; (fname (if dbdat ;; (dbr:dbdat-dbfile dbdat) ;; "nofilenameavailable")) ;; (jfile (conc fname"-journal")) ;; (qryproc (lambda () ;; (if use-mutex (mutex-lock! *db-with-db-mutex*)) ;; (let ((res (apply proc dbdat db params))) ;; the actual call is here. ;; (if use-mutex (mutex-unlock! *db-with-db-mutex*)) ;; ;; (if (vector? dbstruct)(db:done-with dbstruct run-id r/w)) ;; (if dbdat ;; (dbfile:add-dbdat dbstruct run-id dbdat)) ;; ;; (delete-file* crumbfile) ;; res))) ;; (stop-train (conc (dbr:dbstruct-areapath dbstruct)"/stop-the-train"))) ;; ;; (assert (sqlite3:database? db) "FATAL: db:with-db, db is not a database, db="db ;; ", fname="fname) ;; (if (file-exists? jfile) ;; (begin ;; (dbfile:print-err "INFO: "jfile" exists, delaying to reduce database load") ;; (thread-sleep! 0.2))) ;; (if (and use-mutex ;; (common:low-noise-print 120 "over-50-parallel-api-requests")) ;; (dbfile:print-err *api-process-request-count* ;; " parallel api requests being processed in process " ;; (current-process-id))) ;; ", throttling access")) ;; (case (no-condition-db-with-db) ;; ((production)(qryproc)) ;; ((suicide-mode) ;; (handle-exceptions ;; exn ;; (with-output-to-file stop-train ;; (lambda () ;; (db:generic-error-printout exn "Stop train mode, run-id: "run-id ;; " params: "params" proc: "proc))) ;; (qryproc))) ;; (else ;; (condition-case ;; (qryproc) ;; (exn (io-error) ;; (db:generic-error-printout exn "ERROR: i/o error with "fname ;; ". Check permissions, disk space etc. and try again.")) ;; (exn (corrupt) ;; (db:generic-error-printout exn "ERROR: database "fname ;; " is corrupt. Repair it to proceed.")) ;; (exn (busy) ;; (db:generic-error-printout exn "ERROR: database "fname ;; " is locked. Try copying to another location," ;; " remove original and copy back.")) ;; (exn (permission)(db:generic-error-printout exn "ERROR: database "fname ;; " has some permissions problem.")) ;; (exn () ;; (db:generic-error-printout exn "ERROR: Unknown error with database "fname ;; " message: " ;; ((condition-property-accessor 'exn 'message) exn)))))))) ;;====================================================================== ;; another attempt at a transactionized queue ;;====================================================================== ;; ;; ;; (define *transaction-queues* (make-hash-table)) ;; ;; ;; ;; ;; ;; (define (db:get-queue run-id) ;; ;; ;; (let* ((res (hash-table-ref/default *transaction-queues* run-id #f))) ;; ;; ;; (if res ;; ;; ;; res ;; ;; ;; (let* ((newq (make-queue))) ;; ;; ;; (hash-table-set! *transaction-queues* run-id newq) ;; ;; ;; newq)))) ;; ;; ;; ;; ;; ;; (define (db:add-to-transaction-queue dbstruct proc params) ;; ;; ;; (let* ((mbox (make-mailbox)) ;; ;; ;; (q (db:get-queue run-id))) ;; ;; ;; (queue-add! *transaction-queue* (list dbstruct proc mbox)) ;; ;; ;; (mailbox-receive mbox))) ;; ;; ;; ;; ;; ;; (define (db:process-transaction-queue *dbstruct-dbs*) ;; ;; ;; (for-each ;; ;; ;; (lambda (run-id) ;; ;; ;; (let* ((q (hash-table-ref *transaction-queue* run-id))) ;; ;; ;; ;; with-transaction ;; ;; ;; ;; dbstruct ;; ;; ;; ;; pop items from queue and execute them, return results via mailbox ;; ;; ;; q ;; ;; ;; ;; pop ;; ;; ;; )) ;; ;; ;; (hash-table-keys *transaction-queues*))) ;;====================================================================== ;; file utils ;;====================================================================== ;;====================================================================== ;; lazy-safe get file mod time. on any error (file not existing etc.) return 0 ;; (define (dbfile:lazy-modification-time fpath) (handle-exceptions exn (begin (dbfile:print-err "Failed to get modification time for " fpath ", treating it as zero. exn=" exn) 0) (if (file-exists? fpath) (file-modification-time fpath) 0))) ;;====================================================================== ;; find timestamp of newest file associated with a sqlite db file (define (dbfile:lazy-sqlite-db-modification-time fpath) (let* ((glob-list (handle-exceptions exn (begin (dbfile:print-err "Failed to glob " fpath "*, exn=" exn) `(,(conc "/no/such/file, message: " ((condition-property-accessor 'exn 'message) exn)))) (glob (conc fpath "*")))) (file-list (if (eq? 0 (length glob-list)) '("/no/such/file") glob-list))) (apply max (map dbfile:lazy-modification-time file-list)))) ;; dot-locking egg seems not to work, using this for now ;; if lock is older than expire-time then remove it and try again ;; to get the lock ;; (define (dbfile:simple-file-lock fname #!key (expire-time 300)) (let ((fmod-time (handle-exceptions ext (current-seconds) (file-modification-time fname)))) ;; if the file exists, if it has expired, delete it and call this function recursively. (if (file-exists? fname) (if (> (- (current-seconds) fmod-time) expire-time) (begin (dbfile:print-err "simple-file-lock: removing expired file: " fname) (handle-exceptions exn #f (delete-file* fname)) (dbfile:simple-file-lock fname expire-time: expire-time)) #f ) ;; If it doesn't exist, write the host name and process id to the file (let ((key-string (conc (get-host-name) "-" (current-process-id) ": " (argv))) (oup (open-output-file fname))) (with-output-to-port oup (lambda () (print key-string))) (close-output-port oup) ;; sleep 3 seconds and make sure it still exists and contains the same host/process id. ;; if not, return #f (thread-sleep! 0.25) (if (file-exists? fname) (handle-exceptions exn #f (with-input-from-file fname (lambda () (equal? key-string (read-line))))) (begin (dbfile:print-err "dbfile:simple-file-lock created " fname " but it was gone 0.25 seconds later") #f ) ) ) ) ) ) (define (dbfile:simple-file-lock-and-wait fname #!key (expire-time 300)) (let ((end-time (+ expire-time (current-seconds)))) (let loop ((got-lock (dbfile:simple-file-lock fname expire-time: expire-time))) (if got-lock #t (if (> end-time (current-seconds)) (begin (thread-sleep! 3) (loop (dbfile:simple-file-lock fname expire-time: expire-time))) #f))))) (define (dbfile:simple-file-release-lock fname) (handle-exceptions exn #f ;; I don't really care why this failed (at least for now) (delete-file* fname))) (define (dbfile:with-simple-file-lock fname proc #!key (expire-time 300)(run-anyway #f)) (let ((start-time (current-seconds)) (gotlock (dbfile:simple-file-lock-and-wait fname expire-time: expire-time)) (end-time (current-seconds)) ) (if gotlock (let ((res (proc))) (dbfile:simple-file-release-lock fname) res) (begin (dbfile:print-err "dbfile:with-simple-file-lock: " fname " is locked by " (handle-exceptions exn "unreadable" (with-input-from-file fname (lambda () (read-line))))) (dbfile:print-err "wait time = " (- end-time start-time)) (dbfile:print-err "ERROR: simple file lock could not get a lock for " fname " in " expire-time " seconds") (if run-anyway (let ((res (proc))) (dbfile:simple-file-release-lock fname) res) #f))))) (define *get-cache-stmth-mutex* (make-mutex)) (define (db:get-cache-stmth dbdat db stmt) (mutex-lock! *get-cache-stmth-mutex*) (let* (;; (dbdat (dbfile:get-dbdat dbstruct run-id)) (stmt-cache (dbr:dbdat-stmt-cache dbdat)) ;; (stmth (db:hoh-get stmt-cache db stmt)) (stmth (hash-table-ref/default stmt-cache stmt #f)) (result (or stmth (let* ((newstmth (sqlite3:prepare db stmt))) ;; (db:hoh-set! stmt-cache db stmt newstmth) (hash-table-set! stmt-cache stmt newstmth) newstmth)))) (mutex-unlock! *get-cache-stmth-mutex*) result)) ;; (define *mutex-stmth-call* (make-mutex)) ;; ;; (define (db:with-mutex-for-stmth proc) ;; (mutex-lock! *mutex-stmth-call*) ;; (let* ((res (proc))) ;; (mutex-unlock! *mutex-stmth-call*) ;; res)) ) |
Modified dbmod.scm from [2029a02dc3] to [7686817692].
1 2 3 4 5 6 7 | ;;====================================================================== ;; 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 | > | 1 2 3 4 5 6 7 8 | ;;====================================================================== ;; 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 |
︙ | ︙ | |||
15 16 17 18 19 20 21 22 23 24 25 | ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit dbmod)) (module dbmod * | > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > | > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;; ;; 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 dbmod)) (declare (uses dbfile)) (declare (uses commonmod)) (declare (uses debugprint)) (module dbmod * (import scheme) (cond-expand (chicken-4 (import chicken data-structures extras files posix )) (chicken-5 (import chicken.base chicken.condition chicken.file chicken.pathname chicken.process chicken.sort chicken.string chicken.time ) (define file-read-access? file-readable?) (define file-copy copy-file) )) (import format (prefix sqlite3 sqlite3:) matchable typed-records srfi-1 srfi-18 srfi-69 commonmod dbfile debugprint) ;; NOTE: This returns only the name "1.db", "main.db", not the path ;; (define (dbmod:run-id->dbfname run-id) (conc (dbfile:run-id->dbnum run-id)".db")) (define (dbmod:get-dbdir dbstruct) (let* ((areapath (dbr:dbstruct-areapath dbstruct)) (dbdir (conc areapath"/.mtdb"))) (if (and (file-write-access? areapath) (not (file-exists? dbdir))) (create-directory dbdir)) dbdir)) (define (dbmod:run-id->full-dbfname dbstruct run-id) (conc (dbmod:get-dbdir dbstruct) "/"(dbmod:run-id->dbfname run-id))) ;;====================================================================== ;; Read-only cachedb cached direct from disk method ;;====================================================================== (define *dbmod:nfs-db-handles* (make-hash-table)) ;; dbfname -> dbstruct ;; called in rmt.scm nfs-transport-handler (define (dbmod:nfs-get-dbstruct run-id keys init-proc areapath #!key (tmpadj "")) (assert areapath "FATAL: dbmod:nfs-get-dbstruct called without areapath set.") (let* ((dbfname (dbmod:run-id->dbfname run-id)) (dbstruct (hash-table-ref/default *dbmod:nfs-db-handles* dbfname #f))) (if dbstruct dbstruct (let* ((newdbstruct (dbmod:open-dbmoddb areapath run-id dbfname init-proc keys syncdir: 'fromdisk tmpadj: tmpadj))) (hash-table-set! *dbmod:nfs-db-handles* dbfname newdbstruct) newdbstruct)))) ;;====================================================================== ;; The cachedb one-db file per server method goes in here ;;====================================================================== ;; NOTE: the r/w is now w/r, #t=db modified by query, #f=db NOT modified by query (define (dbmod:with-db dbstruct run-id w/r proc params) (let* ((use-mutex w/r) ;; (or (and w/r ;; use the mutex on queries that modify the db and for sync to disk ;; (> *api-process-request-count* 5)) ;; when writes are happening throttle more ;; (> *api-process-request-count* 50))) (dbdat (dbmod:open-db dbstruct run-id (dbfile:db-init-proc))) (dbh (dbr:dbdat-dbh dbdat)) ;; this will be the cachedb handle (dbfile (dbr:dbdat-dbfile dbdat))) ;; if nfs mode do a sync if delta > 2 #;(let* ((last-update (dbr:dbstruct-last-update dbstruct)) ;; (sync-proc (dbr:dbstruct-sync-proc dbstruct)) (curr-secs (current-seconds))) (if (> (- curr-secs last-update) 5) (begin (sync-proc last-update) ;; MOVE THIS CALL TO INSIDE THE sync-proc CALL (dbr:dbstruct-last-update-set! dbstruct curr-secs) ))) (assert (sqlite3:database? dbh) "FATAL: bad db handle in dbmod:with-db") (if use-mutex (mutex-lock! *db-with-db-mutex*)) (let* ((res (let loop ((count 3)) (condition-case (apply proc dbdat dbh params) (exn (busy) (if (> count 0) (begin (debug:print-info 0 *default-log-port* "dbmod:with-db, database is busy, will try "count" more times.") (thread-sleep! 1) (loop (- count 1))) (begin (debug:print-info 0 *default-log-port* "dbmod:with-db, database is busy, giving up.") (exit 1)))) (exn () (dbfile:print-err exn "ERROR: dbmod:with-db: Unknown error with database for run-id "run-id", message: " ((condition-property-accessor 'exn 'message) exn)) (exit 2)))))) (if use-mutex (mutex-unlock! *db-with-db-mutex*)) res))) (define (db:with-db dbstruct run-id w/r proc . params) (dbmod:with-db dbstruct run-id w/r proc params)) ;; (define (dbmod:open-cachedb-db init-proc dbfullname) (let* ((db (if dbfullname (dbmod:safely-open-db dbfullname init-proc #t) (sqlite3:open-database ":memory:"))) (handler (sqlite3:make-busy-timeout 136000))) (sqlite3:set-busy-handler! db handler) (init-proc db) db)) (define (dbmod:open-db dbstruct run-id dbinit) (or (dbr:dbstruct-dbdat dbstruct) (let* ((dbdat (make-dbr:dbdat dbfile: (dbr:dbstruct-dbfile dbstruct) dbh: (dbr:dbstruct-cachedb dbstruct) ))) (dbr:dbstruct-dbdat-set! dbstruct dbdat) dbdat))) ;; NOT USED? (define (dbmod:need-on-disk-db-handle) (case (dbfile:cache-method) ((none tmp) #t) ((cachedb) (case (dbfile:sync-method) ((original) #t) ((attach) #t) ;; we need it to force creation of the on-disk file - FIXME (else (debug:print 0 *default-log-port* "Unknown dbfile:sync-method setting: " (dbfile:sync-method))))) (else (debug:print 0 *default-log-port* "Unknown dbfile:cache-method setting: " (dbfile:cache-method)) #f))) (define (dbmod:safely-open-db dbfullname init-proc write-access) (dbfile:with-simple-file-lock (conc dbfullname".lock") (lambda () (let* ((dbexists (file-exists? dbfullname)) (db (sqlite3:open-database dbfullname)) (handler (sqlite3:make-busy-timeout 136000))) (sqlite3:set-busy-handler! db handler) (if (and (not dbexists) write-access) (init-proc db)) db)) run-anyway: #t)) (define *sync-in-progress* #f) ;; Open the cachedb db and the on-disk db ;; populate the cachedb db with data ;; ;; Updates fields in dbstruct ;; Returns dbstruct ;; ;; * This routine creates the db if not found ;; * Probably can get rid of the dbstruct-in ;; (define (dbmod:open-dbmoddb areapath run-id dbfname-in init-proc keys #!key (dbstruct-in #f) ;; (dbcontext 'megatest) ;; use dashboard to do the dashboard (tmpadj "") ;; add to tmp path (syncdir 'todisk)) ;; todisk is used when caching in /tmp and writing data back to MTRAH (let* ((dbstruct (or dbstruct-in (make-dbr:dbstruct areapath: areapath))) (dbfname (or dbfname-in (dbmod:run-id->dbfname run-id))) (dbpath (dbmod:get-dbdir dbstruct)) ;; directory where all the .db files are kept (dbfullname (conc dbpath"/"dbfname)) ;; (dbmod:run-id->full-dbfname dbstruct run-id)) (dbexists (file-exists? dbfullname)) (tmpdir (common:make-tmpdir-name areapath tmpadj)) (tmpdb (let* ((fname (conc tmpdir"/"dbfname))) fname)) (cachedb (dbmod:open-cachedb-db init-proc ;; (if (eq? (dbfile:cache-method) 'cachedb) ;; #f tmpdb ;; ) )) (write-access (file-write-access? dbpath)) (db (dbmod:safely-open-db dbfullname init-proc write-access)) (tables (db:sync-all-tables-list keys))) (if (not (and (sqlite3:database? cachedb) (sqlite3:database? db))) (begin (debug:print 0 *default-log-port* "ERROR: Failed to properly open "dbfname-in", exiting immediately.") (exit))) ;; (assert (sqlite3:database? cachedb) "FATAL: open-dbmoddb: cachedb is not a db") ;; (assert (sqlite3:database? db) "FATAL: open-dbmoddb: db is not a db") (dbr:dbstruct-cachedb-set! dbstruct cachedb) (dbr:dbstruct-ondiskdb-set! dbstruct db) (dbr:dbstruct-dbfile-set! dbstruct dbfullname) (dbr:dbstruct-dbtmpname-set! dbstruct tmpdb) (dbr:dbstruct-dbfname-set! dbstruct dbfname) (dbr:dbstruct-sync-proc-set! dbstruct (lambda (last-update) (if *sync-in-progress* (debug:print 0 *default-log-port* "WARNING: overlapping calls to sync to disk") (begin ;; turn off writes - send busy or block? ;; call db2db internally ;; turn writes back on ;; (set! *api-halt-writes* #t) ;; do we need a mutex? ;; (dbmod:db-to-db-sync src-db dest-db last-update (dbfile:db-init-proc) keys) (debug:print-info 2 *default-log-port* "Internal sync running from "tmpdb" to "dbfullname) (dbmod:db-to-db-sync tmpdb dbfullname last-update (dbfile:db-init-proc) keys) (set! *api-halt-writes* #f) )))) ;; (dbmod:sync-tables tables #f db cachedb) ;; (thread-sleep! 1) ;; let things settle before syncing in needed data (dbmod:sync-gasket tables #f cachedb db dbfullname 'fromdest keys) ;; ) ;; load into cachedb (dbr:dbstruct-last-update-set! dbstruct (+ (current-seconds) -10)) ;; should this be offset back in time by one second? dbstruct)) ;; (if (eq? syncdir 'todisk) ;; sync to disk normally, sync from in dashboard ;; (dbmod:sync-tables tables last-update cachedb db) ;; (dbmod:sync-tables tables last-update db cachedb)))) ;; ;; direction: 'fromdest 'todest ;; (define (dbmod:sync-gasket tables last-update cachedb dbh dbfname direction keys) (assert (sqlite3:database? cachedb) "FATAL: sync-gasket: cachedb is not a db") (assert (sqlite3:database? cachedb) "FATAL: sync-gasket: dbh is not a db") (debug:print-info 2 *default-log-port* "dbmod:sync-gasket called with sync-method="(dbfile:sync-method)) (case (dbfile:sync-method) ((none) #f) ((attach) (dbmod:attach-sync tables cachedb dbfname direction)) ((newsync) (dbmod:new-sync tables cachedb dbh dbfname direction)) (else ;; original (case direction ((todisk) ;; i.e. from the cache db to the mtrah db (dbmod:sync-tables tables last-update keys cachedb dbh)) (else (dbmod:sync-tables tables last-update keys dbh cachedb)))))) (define (dbmod:close-db dbstruct) ;; do final sync to disk file ;; (do-sync ...) (sqlite3:finalize! (dbr:dbstruct-ondiskdb dbstruct))) ;;====================================================================== ;; Sync db ;;====================================================================== (define (dbmod:calc-use-last-update has-last-update fields 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) ((and last-update (not (pair? last-update)) (not (number? 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))) ;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) ;; dbs are sqlite3 db handles ;; ;; if last-update specified ("field-name" . time-in-seconds) ;; then sync only records where field-name >= time-in-seconds ;; IFF field-name exists ;; ;; Use (db:sync-all-tables-list keys) to get the tbls input ;; (define (dbmod:sync-tables tbls last-update keys fromdb todb) (debug:print-info 2 *default-log-port* "dbmod:sync-tables called, from: "fromdb", to: "todb) (assert (sqlite3:database? fromdb) "FATAL: dbmod:sync-tables called with fromdb not a database" fromdb) (assert (sqlite3:database? todb) "FATAL: dbmod:sync-tables called with fromdb not a database" todb) (let ((stmts (make-hash-table)) ;; table-field => stmt (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 )) (numrecs (make-hash-table)) (start-time (current-milliseconds)) (tot-count 0)) (for-each ;; table (lambda (tabledat) (let* ((tablename (car tabledat)) (fields (cdr tabledat)) (has-last-update (member "last_update" fields)) (use-last-update (dbmod:calc-use-last-update has-last-update fields last-update)) (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)) #f)) (last-update-field (if use-last-update (if (number? last-update) "last_update" (car last-update)) #f)) (num-fields (length fields)) (field->num (make-hash-table)) (num->field (apply vector (map car fields))) ;; BBHERE (full-sel (conc "SELECT " (string-intersperse (map car fields) ",") " FROM " tablename (if use-last-update ;; apply last-update criteria (conc " WHERE " last-update-field " >= " last-update-value) "") ";")) (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) " " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );")) (fromdat '()) (fromdats '()) (totrecords 0) (batch-len 100) ;; (string->number (or (configf:lookup *configdat* "sync" "batchsize") "100"))) (todat (make-hash-table)) (count 0) (field-names (map car fields))) ;; set up the field->num table (for-each (lambda (field) (hash-table-set! field->num field count) (set! count (+ count 1))) fields) ;; read the source table ;; store a list of all rows in the table in fromdat, up to batch-len. ;; Then add fromdat to the fromdats list, clear fromdat and repeat. (sqlite3:for-each-row (lambda (a . b) (set! fromdat (cons (apply vector a b) fromdat)) (if (> (length fromdat) batch-len) (begin (set! fromdats (cons fromdat fromdats)) (set! fromdat '()) (set! totrecords (+ totrecords 1))))) fromdb full-sel) ;; Count less than batch-len as a record (if (> (length fromdat) 0) (set! totrecords (+ totrecords 1))) ;; tack on remaining records in fromdat (if (not (null? fromdat)) (set! fromdats (cons fromdat fromdats))) (sqlite3:for-each-row (lambda (a . b) (hash-table-set! todat a (apply vector a b))) todb full-sel) ;; first pass implementation, just insert all changed rows (let* ((db todb) (drp-trigger (if (member "last_update" field-names) (db:drop-trigger db tablename) #f)) (has-last-update (member "last_update" field-names)) (is-trigger-dropped (if has-last-update (db:is-trigger-dropped db tablename) #f)) (stmth (sqlite3:prepare db full-ins)) (changed-rows 0)) (for-each (lambda (fromdat-lst) (mutex-lock! *db-transaction-mutex*) (sqlite3:with-transaction db (lambda () (for-each ;; (lambda (fromrow) (let* ((a (vector-ref fromrow 0)) (curr (hash-table-ref/default todat a #f)) (same #t)) (let loop ((i 0)) (if (or (not curr) (not (equal? (vector-ref fromrow i)(vector-ref curr i)))) (set! same #f)) (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))) (set! changed-rows (+ changed-rows 1)))))) fromdat-lst))) (mutex-unlock! *db-transaction-mutex*)) fromdats) ;; (debug:print 0 *default-log-port* "row="row) (sqlite3:finalize! stmth) (if (member "last_update" field-names) (db:create-trigger db tablename))) )) 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. (for-each (lambda (dat) (let ((tblname (car dat)) (count (cdr dat))) (set! tot-count (+ tot-count count)))) (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))) tot-count)) (define (has-last-update dbh tablename) (let* ((has-last #f)) (sqlite3:for-each-row (lambda (name) (if (equal? name "last_update") (set! has-last #t))) dbh (conc "SELECT name FROM pragma_table_info('"tablename"') as tblInfo;")) has-last)) (define (replace-question-marks-with-number str num) (define (replace-helper str index result) (if (>= index (string-length str)) result (let ((char (string-ref str index))) (if (char=? char #\?) (replace-helper str (+ index 1) (string-append result (number->string num))) (replace-helper str (+ index 1) (string-append result (string char))))))) (replace-helper str 0 "")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) ;; ;; direction = fromdest, todisk ;; mode = 'full, 'incr ;; ;; Idea: youngest in dest is last_update time ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (dbmod:attach-sync tables dbh destdbfile direction #!key (mode 'full) (no-update '("keys")) ;; do ) (debug:print-info 2 *default-log-port* "dbmod:attach-sync") (let* ((num-changes 0) (update-changed (lambda (num-changed table qryname) (if (> num-changed 0) (begin (debug:print-info 0 *default-log-port* "Changed "num-changed" rows for table "table", qry "qryname) (set! num-changes (+ num-changes num-changed))))))) (debug:print 2 *default-log-port* "Doing sync "direction" "destdbfile) (if (not (sqlite3:auto-committing? dbh)) (debug:print 0 *default-log-port* "Skipping sync due to transaction in flight.") (let* ((table-names (map car tables)) (dest-exists (file-exists? destdbfile))) (assert dest-exists "FATAL: sync called with non-existant file, "destdbfile) ;; attach the destdbfile ;; for each table ;; insert into dest.<table> select * from src.<table> where last_update>last_update ;; done (debug:print 2 *default-log-port* "Attaching "destdbfile" as auxdb") (handle-exceptions exn (begin (debug:print 0 *default-log-port* "ATTACH failed, exiting. exn="(condition->list exn)) (exit 1)) (sqlite3:execute dbh (conc "ATTACH '"destdbfile"' AS auxdb;"))) (for-each (lambda (table) (let* ((dummy (debug:print 2 *default-log-port* "Doing table " table)) (tbldat (alist-ref table tables equal?)) (fields (map car tbldat)) (no-id-fields (filter (lambda (x)(not (equal? x "id"))) fields)) (fields-str (string-intersperse fields ",")) (no-id-fields-str (string-intersperse no-id-fields ",")) (dir (eq? direction 'todisk)) (fromdb (if dir "main." "auxdb.")) (todb (if dir "auxdb." "main.")) (set-str (string-intersperse (map (lambda (field) (conc fromdb field"="todb field)) fields) ",")) (stmt1 (conc "INSERT OR IGNORE INTO "todb table " SELECT * FROM "fromdb table";")) (stmt2 (conc "INSERT OR IGNORE INTO "todb table " SELECT * FROM "fromdb table" WHERE "fromdb table".id=?;")) (stmt8 (conc "UPDATE "todb table" SET ("no-id-fields-str") = (SELECT "no-id-fields-str" FROM "fromdb table" WHERE "todb table".id="fromdb table".id" (conc " AND "fromdb table".last_update > "todb table".last_update);") ");")) (update-string (conc "UPDATE "todb table" SET ")) (split-update (let () (for-each (lambda (column) (set! update-string (conc update-string column" = (SELECT "column" FROM "fromdb table" WHERE "fromdb table".id=?), ")) ) no-id-fields ) ;; drop the last ", " (conc (substring update-string 0 (-(string-length update-string) 2)) " WHERE "todb table".id=? ") ) ) (stmt9 (conc "UPDATE "todb table" SET ("no-id-fields-str") = " "(SELECT "no-id-fields-str" FROM "fromdb table" WHERE "fromdb table".id=?)" " WHERE "todb table".id=?")) (newrec (conc "SELECT id FROM "fromdb table" WHERE id NOT IN (SELECT id FROM "todb table");")) (changedrec (conc "SELECT "fromdb table".id FROM "fromdb table" join "todb table" on "fromdb table".id="todb table".id WHERE "fromdb table".last_update > "todb table".last_update;")) (start-ms (current-milliseconds)) (new-ids (sqlite3:fold-row (lambda (res id)(cons id res)) '() dbh newrec))) (update-changed (length new-ids) table "new records") (mutex-lock! *db-transaction-mutex*) (handle-exceptions exn (debug:print 0 *default-log-port* "Transaction update of id fields in "table" failed.") (sqlite3:with-transaction dbh (lambda () (for-each (lambda (id) (sqlite3:execute dbh stmt2 id)) new-ids)))) (if (member "last_update" fields) (handle-exceptions exn (debug:print 0 *default-log-port* "Transaction update of non id fields in "table" failed.") (sqlite3:with-transaction dbh (lambda () (let* ((changed-ids (sqlite3:fold-row (lambda (res id)(cons id res)) '() dbh changedrec)) (sql-query "") ) (update-changed (length changed-ids) table "changed records") (for-each (lambda (id) (let* ((update-with-ids (replace-question-marks-with-number split-update id)) ) (debug:print 2 *default-log-port* "about to do sqlite3:execute " dbh " " update-with-ids ) (handle-exceptions exn (debug:print 0 *default-log-port* "update from " fromdb table " to " todb table " failed: " ((condition-property-accessor 'exn 'message) exn)) (sqlite3:execute dbh update-with-ids) ) (debug:print 2 *default-log-port* "after sqlite3:execute") ) ) changed-ids ) ) ) ) ) ) (mutex-unlock! *db-transaction-mutex*) (debug:print 2 *default-log-port* "Synced table "table " in "(- (current-milliseconds) start-ms)"ms") )) table-names) (sqlite3:execute dbh "DETACH auxdb;"))) num-changes)) ;; prefix is "" or "auxdb." ;; ;; (define (dbmod:last-update-patch dbh prefix) ;; (let (( ;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) ;; ;; direction = fromdest, todest ;; mode = 'full, 'incr ;; ;; Idea: youngest in dest is last_update time ;; (define (dbmod:new-sync tables dbh1 dbh2 destdbfile direction #!key (mode 'full)) (debug:print 0 *default-log-port* "Doing new-sync "direction" "destdbfile) (if (not (sqlite3:auto-committing? dbh1)) (debug:print 0 *default-log-port* "Skipping sync due to transaction in flight.") (let* ((table-names (map car tables)) (dest-exists (file-exists? destdbfile))) (assert dest-exists "FATAL: sync called with non-existant file, "destdbfile) (for-each (lambda (table) (let* ((tbldat (alist-ref table tables equal?)) (fields (map car tbldat)) (no-id-fields (filter (lambda (x)(not (equal? x "id"))) fields)) (questionmarks (string-intersperse (make-list (length no-id-fields) "?") ",")) (fields-str (string-intersperse fields ",")) (no-id-fields-str (string-intersperse no-id-fields ",")) (dir (eq? direction 'todest)) (fromdb (if dir dbh1 dbh2)) (todb (if dir dbh2 dbh1)) (set-str (string-intersperse (map (lambda (field) (conc fromdb field"="todb field)) fields) ",")) ;; (stmt1 (conc "INSERT OR IGNORE INTO "todb table ;; " SELECT * FROM "fromdb table";")) ;; (stmt8 (conc "UPDATE "todb table" SET ("no-id-fields-str") = (SELECT "no-id-fields-str" FROM "fromdb table " WHERE "todb table".id="fromdb table".id" ;; (if (member "last_update" fields) ;; (conc " AND "fromdb table".last_update > "todb table".last_update);") ;; ");"))) (stmt1 (conc "SELECT MAX(last_update) FROM "table";")) ;; use the highest last_update as your time reference (stmt2 (conc "SELECT no-id-fields-str FROM "table" WHERE last_update>?;")) (stmt3 (conc "UPDATE "table" SET ("no-id-fields-str") = ("questionmarks") WHERE id=?;")) (start-ms (current-milliseconds))) (debug:print 0 *default-log-port* "stmt3="stmt3) (if (sqlite3:auto-committing? dbh1) (begin (handle-exceptions exn (debug:print 0 *default-log-port* "Transaction update of "table" failed. "(condition->list exn)) (sqlite3:with-transaction dbh1 (lambda () (sqlite3:execute dbh1 stmt1) ;; get all new rows #;(if (member "last_update" fields) (sqlite3:execute dbh1 stmt8)) ;; get all updated rows ;; (sqlite3:execute dbh stmt5) ;; (sqlite3:execute dbh stmt4) ;; if it worked this would be better for incremental up ;; (sqlite3:execute dbh stmt6) ))) (debug:print 0 *default-log-port* "Synced table "table " in "(- (current-milliseconds) start-ms)"ms")) (debug:print 0 *default-log-port* "Skipping sync of table "table" due to transaction in flight.")))) table-names) (sqlite3:execute dbh1 "DETACH auxdb;")))) ;;====================================================================== ;; Moved from dbfile ;;====================================================================== ;; wait up to aprox n seconds for a journal to go away ;; (define (tasks:wait-on-journal path n #!key (remove #f)(waiting-msg #f)) (if (not (string? path)) (debug:print-error 0 *default-log-port* "Called tasks:wait-on-journal with path=" path " (not a string)") (let ((fullpath (conc path "-journal"))) (handle-exceptions exn (begin (print-call-chain (current-error-port)) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 5 *default-log-port* " exn=" (condition->list exn)) (debug:print 0 *default-log-port* "tasks:wait-on-journal failed. Continuing on, you can ignore this call-chain") #t) ;; if stuff goes wrong just allow it to move on (let loop ((journal-exists (file-exists? fullpath)) (count n)) ;; wait ten times ... (if journal-exists (begin (if (and waiting-msg (eq? (modulo n 30) 0)) (debug:print 0 *default-log-port* waiting-msg)) (if (> count 0) (begin (thread-sleep! 1) (loop (file-exists? fullpath) (- count 1))) (begin (debug:print 0 *default-log-port* "ERROR: removing the journal file " fullpath ", this is not good. Look for disk full, write access and other issues.") (if remove (system (conc "rm -rf " fullpath))) #f))) #t)))))) ;;====================================================================== ;; M E T A G E T A N D S E T V A R S ;;====================================================================== ;; returns number if string->number is successful, string otherwise ;; also updates *global-delta* ;; (define (db:get-var dbstruct var) (let* ((res #f)) (db:with-db dbstruct #f #f ;; for the moment vars are only stored in main.db (lambda (dbdat db) (sqlite3:for-each-row (lambda (val) (set! res val)) db "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 (dbdat 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 (dbdat 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 (dbdat db) (sqlite3:execute (db:get-cache-stmth dbdat 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 (dbdat db) (sqlite3:execute (db:get-cache-stmth dbdat db "UPDATE metadat SET val=val+? WHERE var=?;") val var)))) (define (db:del-var dbstruct var) (db:with-db dbstruct #f #t (lambda (dbdat db) (sqlite3:execute (db:get-cache-stmth dbdat db "DELETE FROM metadat WHERE var=?;") var)))) (define (db:get-toplevels-and-incompletes dbstruct run-id running-deadtime remotehoststart-deadtime) (let* ((toplevels '()) (oldlaunched '()) (incompleted '())) (db:with-db dbstruct run-id #t ;; not a write but problemtic (lambda (dbdat db) (let* ((stmth1 (db:get-cache-stmth dbdat db "SELECT id,rundir,uname,testname,item_path,event_time,run_duration FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING');")) (stmth2 (db:get-cache-stmth dbdat db "SELECT id,rundir,uname,testname,item_path,event_time,run_duration FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('REMOTEHOSTSTART');")) (stmth3 (db:get-cache-stmth dbdat db "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');"))) ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes ;; ;; HOWEVER: this code in run:test seems to work fine ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) ;; (db:test-get-run_duration testdat))) ;; 600) (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path event-time run-duration) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? (begin (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id)) (begin (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)) (debug:print-info 0 *default-log-port* "Found old test in RUNNING state, test-id=" test-id" exceeded running-deadtime "running-deadtime" now="(current-seconds) " event-time="event-time" run-duration="run-duration)))) stmth1 run-id running-deadtime) ;; default time 720 seconds (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path event-time run-duration) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? (begin (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id)) (begin (debug:print-info 0 *default-log-port* "Found old test in REMOTEHOSTSTART state, test-id=" test-id " exceeded running-deadtime "running-deadtime" now="(current-seconds)" event-time="event-time " run-duration="run-duration) (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))) stmth2 run-id remotehoststart-deadtime) ;; default time 230 seconds ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) (begin (debug:print-info 0 *default-log-port* "Found old test in LAUNCHED state, test-id=" test-id " 1 day since event_time marked") (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))) stmth3 run-id)))) (list incompleted oldlaunched toplevels))) ;;====================================================================== ;; db to db sync ;;====================================================================== (define (dbmod:db-to-db-sync src-db dest-db last-update init-proc keys) (if (and (file-exists? src-db) ;; can't proceed without a source (file-read-access? src-db)) (let* ((have-dest (file-exists? dest-db)) (dest-file-wr (and have-dest (file-write-access? dest-db))) ;; exists and writable (dest-dir (or (pathname-directory dest-db) ".")) (dest-dir-wr (and (file-exists? dest-dir) (file-write-access? dest-dir))) (d-wr (or (and have-dest dest-file-wr) dest-dir-wr)) (copied (if (and (not have-dest) dest-dir-wr) (begin (file-copy src-db dest-db) #t) #f))) (if copied (begin (debug:print-info 0 *default-log-port* "db-to-db-sync done with file-copy") #t) (let* ((tables (db:sync-all-tables-list keys)) (sdb (dbmod:safely-open-db src-db init-proc #t)) (ddb (dbmod:safely-open-db dest-db init-proc d-wr)) (res (dbmod:sync-gasket tables last-update sdb ddb dest-db 'todisk keys))) (sqlite3:finalize! sdb) (sqlite3:finalize! ddb) res))) #f)) ;; ====================================================================== ;; dbstats ;;====================================================================== ;; (define *dbstruct-dbs* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this. ;; db stats (define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total > (define *db-stats-mutex* (make-mutex)) (define (rmt:print-db-stats) (let ((fmtstr "~40a~8-d~20-d~20,2-f")) ;; "~20,2-f" (debug:print 0 *default-log-port* "DB Stats\n========") (debug:print 0 *default-log-port* (format #f "~40a~8a~20a~10a" "Cmd" "Count" "TotTime" "Avg")) (for-each (lambda (cmd) (let* ((dat (hash-table-ref *db-stats* cmd)) (count (dbstat-cnt dat)) (tottime (dbstat-tottime dat))) (debug:print 0 *default-log-port* (format #f fmtstr cmd count tottime (/ tottime count))))) (sort (hash-table-keys *db-stats*) (lambda (a b) (> (dbstat-tottime (hash-table-ref *db-stats* a)) (dbstat-tottime (hash-table-ref *db-stats* b)))))))) (defstruct dbstat (cnt 0) (tottime 0)) (define (db:add-stats cmd run-id params delta) (let* ((modified-cmd (if (eq? cmd 'general-call) (string->symbol (conc "general-call-" (car params))) cmd)) (rec (hash-table-ref/default *db-stats* modified-cmd #f))) (if (not rec) (let ((new-rec (make-dbstat))) (hash-table-set! *db-stats* modified-cmd new-rec) (set! rec new-rec))) (dbstat-cnt-set! rec (+ (dbstat-cnt rec) 1)) (dbstat-tottime-set! rec (+ (dbstat-tottime rec) delta)))) ) ;; ATTIC #;(let* ((syncer-logfile (conc areapath"/logs/"dbfname"-syncer.log")) (sync-cmd (if (eq? syncdir 'todisk) (conc "(NBFAKE_LOG="syncer-logfile" nbfake megatest -db2db -from "tmpdb" -to "dbfullname" -period 5 -timeout 10 > /dev/null 2&>1)&") (conc "(NBFAKE_LOG="syncer-logfile" nbfake megatest -db2db -from "dbfullname" -to "tmpdb" -period 5 -timeout 10 > /dev/null 2&>1)&"))) (synclock-file (conc dbfullname".lock")) (syncer-running-file (conc dbfullname"-sync-running")) (synclock-mod-time (if (file-exists? synclock-file) (handle-exceptions exn #f (file-modification-time synclock-file)) #f)) (thethread (lambda () (thread-start! (make-thread (lambda () (set! *sync-in-progress* #t) (debug:print-info "Running "sync-cmd) (if (file-exists? syncer-running-file) (debug:print-info 0 *default-log-port* "Syncer still running, skipping syncer start.") (system sync-cmd)) (set! *sync-in-progress* #f))))))) (if ((if (eq? syncdir 'todisk) < >) ;; use less than for todisk, greater than for from disk (file-modification-time tmpdb) (file-modification-time dbfullname)) (debug:print 4 *default-log-port* "Skipping sync, "tmpdb" older than "dbfullname) (if synclock-mod-time (if (> (- (current-seconds) synclock-mod-time) 20) ;; something wrong with sync, remove file (begin (handle-exceptions exn #f (begin (debug:print 0 *default-log-port* "Sync lock file " synclock-file "is older than 20 seconds (" synclock-mod-time " seconds). Removing it") (delete-file synclock-file) ) ) (thethread)) (debug:print 0 *default-log-port* "Skipping sync, lockfile "synclock-file" found.")) (thethread)))) |
Modified dcommon.scm from [0ce4957460] to [9dc61d6811].
︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 24 25 26 27 | ;; 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/>. ;; ;;====================================================================== (use format) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) (import canvas-draw-iup) (use regex typed-records matchable) | > > > > > > > | | < | < | 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 | ;; 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 dcommon)) (declare (uses gutils)) (declare (uses db)) (declare (uses commonmod)) (declare (uses rmtmod)) (use format) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) (import canvas-draw-iup) (use regex typed-records matchable) (import commonmod rmtmod debugprint) (include "megatest-version.scm") (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") (include "run_records.scm") |
︙ | ︙ | |||
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 | please-update tabdats update-mutex updaters updating uidat ;; needs to move to tabdat at some time hide-not-hide-tabs ) (define (dboard:commondat-make) (make-dboard:commondat curr-tab-num: 0 tabdats: (make-hash-table) please-update: #t update-mutex: (make-mutex) updaters: (make-hash-table) updating: #f hide-not-hide-tabs: #f )) ;; RADT => Matrix defstruct addition (defstruct dboard:graph-dat ((id #f) : string) ((color #f) : vector) ((flag #t) : boolean) ((cell #f) : number) ) ;; data for runs, tests etc. was used in run summary? ;; (defstruct dboard:runsdat ;; new system runs-index ;; target/runname => colnum tests-index ;; testname/itempath => rownum | > > > > > > > > > > > > > > > > > > > > > > > | 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 | please-update tabdats update-mutex updaters updating uidat ;; needs to move to tabdat at some time hide-not-hide-tabs target ) (define (dboard:commondat-make) (make-dboard:commondat curr-tab-num: 0 tabdats: (make-hash-table) please-update: #t update-mutex: (make-mutex) updaters: (make-hash-table) updating: #f hide-not-hide-tabs: #f target: "" )) ;; RADT => Matrix defstruct addition (defstruct dboard:graph-dat ((id #f) : string) ((color #f) : vector) ((flag #t) : boolean) ((cell #f) : number) ) ;; RA => returns the tabdat stored at hashkey passed in commondat-tabdats table (e.g. 0 gives summary) ;; (define (dboard:common-get-tabdat commondat #!key (tab-num #f)) (let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat) 0)) ;; tab-num value is curr-tab-num value in passed commondat (ht (dboard:commondat-tabdats commondat)) (res (hash-table-ref/default ht tnum #f))) (or res (let ((new-tabdat (dboard:tabdat-make-data))) (hash-table-set! ht tnum new-tabdat) new-tabdat)))) ;; RA => sets the tabdat passed to the hashkey at commondat:tabdats hash table ;; (define (dboard:common-set-tabdat! commondat tabnum tabdat) (hash-table-set! (dboard:commondat-tabdats commondat) tabnum tabdat)) ;; data for runs, tests etc. was used in run summary? ;; (defstruct dboard:runsdat ;; new system runs-index ;; target/runname => colnum tests-index ;; testname/itempath => rownum |
︙ | ︙ | |||
520 521 522 523 524 525 526 | (xterm (lambda () (if (directory-exists? rundir) (let* ((shell (if (get-environment-variable "SHELL") (conc "-e " (get-environment-variable "SHELL")) "")) (command (conc "cd " rundir ";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) | | < > > > > | | 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 | (xterm (lambda () (if (directory-exists? rundir) (let* ((shell (if (get-environment-variable "SHELL") (conc "-e " (get-environment-variable "SHELL")) "")) (command (conc "cd " rundir ";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) ;; (print "Command =" command) (common:without-vars command "MT_.*")) (message-window (conc "Directory " rundir " not found")))))) (xterm) ) ) ) ) ;;====================================================================== ;; D A T A T A B L E S ;;====================================================================== ;; Table of keys (define (dcommon:keys-matrix rawconfig) (let* ((curr-row-num 1) (key-vals (configf:section-vars rawconfig "fields")) (keys-matrix (iup:matrix #:alignment1 "ALEFT" #:expand "YES" ;; "HORIZONTAL" ;; "VERTICAL" ;; #:scrollbar "YES" #:numcol 1 #:numlin (length key-vals) #:numcol-visible 1 #:numlin-visible (length key-vals) #:click-cb (lambda (obj lin col status) (debug:print 0 *default-log-port* "obj: " obj " lin: " lin " col: " col " status: " status))))) ;; (iup:attribute-set! keys-matrix "0:0" "Run Keys") (iup:attribute-set! keys-matrix "WIDTH0" 0) (iup:attribute-set! keys-matrix "0:1" "Key Name") ;; (iup:attribute-set! keys-matrix "WIDTH1" "100") ;; fill in keys (for-each (lambda (var) |
︙ | ︙ | |||
630 631 632 633 634 635 636 | (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) (max-col-vis (if (> max-col 10) 10 max-col)) (numrows 1) (numcols 1)) | > | | 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 | (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) (max-col-vis (if (> max-col 10) 10 max-col)) (numrows 1) (numcols 1)) (if (common:low-noise-print 60 "runs-stats-update-clear") (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) |
︙ | ︙ | |||
699 700 701 702 703 704 705 | #:numcol 7 #:numcol-visible 7 #:numlin-visible 5 )) (colnames (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "RunTime" "State" "RunId")) (updater (lambda () (if (dashboard:monitor-changed? commondat tabdat) | > | > > | | | | | | | | | 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 | #:numcol 7 #:numcol-visible 7 #:numlin-visible 5 )) (colnames (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "RunTime" "State" "RunId")) (updater (lambda () (if (dashboard:monitor-changed? commondat tabdat) (let ((servers (case (rmt:transport-mode) ((http)(server:choose-server *toppath* 'all-valid)) ;; (server:get-list *toppath* limit: 10))) (else '())))) (iup:attribute-set! servers-matrix "NUMLIN" (length servers)) ;; (set! colnum 0) ;; (for-each (lambda (colname) ;; ;; (print "colnum: " colnum " colname: " colname) ;; (iup:attribute-set! servers-matrix (conc "0:" colnum) colname) ;; (set! colnum (+ 1 colnum))) ;; colnames) (set! rownum 1) (for-each (lambda (server) (set! colnum 0) ;; (("192.168.0.127" 60215 1669088591.0 "c85484f764df7a8550b0224409bd4bcd") (match-let (((host port start-time server-id pid) server)) (let* (;; (uptime (- (current-seconds) mod-time)) (runtime (if start-time (- (current-seconds) start-time) 0)) (vals (list "-" ;; (vector-ref server 0) ;; Id "-" ;; (vector-ref server 9) ;; MT-Ver pid ;; (vector-ref server 1) ;; Pid host ;; (vector-ref server 2) ;; Hostname (conc host ":" port) ;; (conc (vector-ref server 3) ":" (vector-ref server 4)) ;; IP:Port (seconds->hr-min-sec runtime) ;; (- (current-seconds) start-time)) ;; (vector-ref server 6))) "-" #;(cond ((< uptime 5) "alive") ((< uptime 16) "probably alive");; less than 15 seconds since mod, call it alive (vector-ref server 8) ;; State (else "dead")) "-" ;; (vector-ref server 12) ;; RunId ))) (for-each (lambda (val) (let* ((row-col (conc rownum ":" colnum)) (curr-val (iup:attribute servers-matrix row-col))) (if (not (equal? (conc val) curr-val)) (begin (iup:attribute-set! servers-matrix row-col val) (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum)))) (set! colnum (+ 1 colnum)))) vals) (set! rownum (+ rownum 1))) (iup:attribute-set! servers-matrix "REDRAW" "ALL"))) (sort servers (lambda (a b)(> (caddr a)(caddr b)))))))))) (set! colnum 0) (for-each (lambda (colname) (iup:attribute-set! servers-matrix (conc "0:" colnum) colname) (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum)) (set! colnum (+ colnum 1))) colnames) ;; (set! dashboard:update-servers-table updater) |
︙ | ︙ | |||
795 796 797 798 799 800 801 | (top (iup:show fd #:modal? "YES"))) (iup:attribute-set! area-name "VALUE" ;; was source-tb, no idea what is correct (iup:attribute fd "VALUE")) (iup:destroy! fd)))) ;; (lambda (obj) ;; (iup:show (iup:file-dialog)) ;; (print "File->open " obj))) | | | | | | | | | | > | | | 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 | (top (iup:show fd #:modal? "YES"))) (iup:attribute-set! area-name "VALUE" ;; was source-tb, no idea what is correct (iup:attribute fd "VALUE")) (iup:destroy! fd)))) ;; (lambda (obj) ;; (iup:show (iup:file-dialog)) ;; (print "File->open " obj))) ;; (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj))) (iup:menu-item "Exit" #:action (lambda (obj)(exit))))) ;; (iup:menu-item "Tools" (iup:menu ;; (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah"))) ;; ;; (iup:menu-item "Show dialog" #:action (lambda (obj) ;; ;; (show message-window ;; ;; #:modal? #t ;; ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current ;; ;; ;; #:x 'mouse ;; ;; ;; #:y 'mouse ;; ;; ) ;; )) )) ;;====================================================================== ;; CANVAS STUFF FOR TESTS ;;====================================================================== (define (dcommon:draw-test cnv xoffset yoffset scalef x y w h name selected) (let* ((llx (dcommon:x->canvas x scalef xoffset)) |
︙ | ︙ | |||
951 952 953 954 955 956 957 | (define (dcommon:y->canvas y scalef yoffset) (+ yoffset (* y scalef))) ;; sizex, sizey - canvas size ;; originx, originy - canvas origin ;; | | | > | | 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 | (define (dcommon:y->canvas y scalef yoffset) (+ yoffset (* y scalef))) ;; sizex, sizey - canvas size ;; originx, originy - canvas origin ;; (define (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records) (let* ((dot-data ;; (map cdr (filter ;; (lambda (x)(equal? "node" (car x))) (map string-split (tests:lazy-dot test-records "plain" sizex sizey))) ;; (tests:easy-dot test-records "plain"))) (xoffset (dcommon:get-xoffset tests-draw-state sizex xadj)) (yoffset (dcommon:get-yoffset tests-draw-state sizey yadj)) (no-dot (configf:lookup *configdat* "setup" "nodot")) (boxh 15) (boxw 10) (margin 5) (tests-info (hash-table-ref tests-draw-state 'tests-info)) |
︙ | ︙ | |||
1122 1123 1124 1125 1126 1127 1128 1129 1130 | #:value "megatest " #:expand "HORIZONTAL" #:readonly "YES" #:font "Courier New, -12" ))) (dboard:tabdat-command-tb-set! data tb) tb) (iup:button "Execute" #:size "50x" #:action (lambda (obj) | > | > > > > > > > > | > > > > > | 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 | #:value "megatest " #:expand "HORIZONTAL" #:readonly "YES" #:font "Courier New, -12" ))) (dboard:tabdat-command-tb-set! data tb) tb) (iup:button "Execute" #:size "50x" #:action (lambda (obj) (let ((cmd (iup:attribute (dboard:tabdat-command-tb data) "VALUE"))) (if (substring-index "no-runname-specified" cmd) (debug:print 0 *default-log-port* "ERROR: no runname specified") (begin (if (substring-index "no-target-selected" cmd) (debug:print 0 *default-log-port* "ERROR: no target selected") (begin (if (not (substring-index "-run" cmd)) (debug:print 0 *default-log-port* "ERROR: No target selected") (common:run-a-command (iup:attribute (dboard:tabdat-command-tb data) "VALUE")) ) ) ) ) ))))))) ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) ;; (system cmd))))))) (define (dcommon:command-action-selector commondat tabdat #!key (tab-num #f)) (iup:frame #:title "Set the action to take" (iup:hbox |
︙ | ︙ | |||
1154 1155 1156 1157 1158 1159 1160 | (iup:frame #:title "Runname" (let* ((default-run-name (seconds->work-week/day (current-seconds))) (tb (iup:textbox #:expand "HORIZONTAL" #:action (lambda (obj val txt) (debug:catch-and-dump (lambda () | < | | 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 | (iup:frame #:title "Runname" (let* ((default-run-name (seconds->work-week/day (current-seconds))) (tb (iup:textbox #:expand "HORIZONTAL" #:action (lambda (obj val txt) (debug:catch-and-dump (lambda () (dboard:tabdat-run-name-set! tabdat txt) ;; (iup:attribute obj "VALUE")) (dashboard:update-run-command tabdat)) "command-runname-selector tb action")) #:value (or default-run-name (dboard:tabdat-run-name tabdat)))) (lb (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" #:action (lambda (obj val index lbstate) (debug:catch-and-dump (lambda () (if (not (equal? val "")) (begin |
︙ | ︙ | |||
1180 1181 1182 1183 1184 1185 1186 | (runs-for-targ (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f 0)) (runs-header (vector-ref runs-for-targ 0)) (runs-dat (vector-ref runs-for-targ 1)) (run-names (cons default-run-name (map (lambda (x) (db:get-value-by-header x runs-header "runname")) runs-dat)))) | < | 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 | (runs-for-targ (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f 0)) (runs-header (vector-ref runs-for-targ 0)) (runs-dat (vector-ref runs-for-targ 1)) (run-names (cons default-run-name (map (lambda (x) (db:get-value-by-header x runs-header "runname")) runs-dat)))) ;; (iup:attribute-set! lb "REMOVEITEM" "ALL") (iuplistbox-fill-list lb run-names selected-item: default-run-name)))))) ;; (dboard:tabdat-updater-for-runs-set! tabdat refresh-runs-list) (dboard:commondat-add-updater commondat refresh-runs-list tab-num: tab-num) ;; (refresh-runs-list) (dboard:tabdat-run-name-set! tabdat default-run-name) (iup:hbox |
︙ | ︙ | |||
1351 1352 1353 1354 1355 1356 1357 | (colnum 1)) (if (> rownum max-row)(set! max-row rownum)) (let* ((status (vector-ref hed 3)) (val (vector-ref hed (- colnum 1))) (bgcolor (cond ((member (conc status) '("" "-" "#<unspecified>")) running-color) | < | 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 | (colnum 1)) (if (> rownum max-row)(set! max-row rownum)) (let* ((status (vector-ref hed 3)) (val (vector-ref hed (- colnum 1))) (bgcolor (cond ((member (conc status) '("" "-" "#<unspecified>")) running-color) ((member (conc status) '("0" 0)) white) (else test-status-color))) ; (else failcolor))) (mtrx-rc (conc rownum ":" colnum))) ;;(print "BB> status=>"status"< bgcolor="bgcolor) (iup:attribute-set! steps-matrix mtrx-rc (if val (conc val) "")) |
︙ | ︙ | |||
1411 1412 1413 1414 1415 1416 1417 | (or (> monitor-modtime *last-monitor-update-time*) (> (- run-update-time *last-monitor-update-time*) 5))) ;; update every 1/2 minute just in case (begin (set! *last-monitor-update-time* run-update-time) ;; monitor-modtime) #t) #f))) | < < < < < < < < < < < < < < < < < < < < < < < < < < | 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 | (or (> monitor-modtime *last-monitor-update-time*) (> (- run-update-time *last-monitor-update-time*) 5))) ;; update every 1/2 minute just in case (begin (set! *last-monitor-update-time* run-update-time) ;; monitor-modtime) #t) #f))) (define (dboard:get-last-db-update tabdat context) (hash-table-ref/default (dboard:tabdat-last-db-update tabdat) context 0)) (define (dboard:set-last-db-update! tabdat context newtime) (hash-table-set! (dboard:tabdat-last-db-update tabdat) context newtime)) |
︙ | ︙ |
Added debugprint.scm version [b5deae7454].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (declare (unit debugprint)) (declare (uses mtargs)) (module debugprint * (import scheme) (cond-expand (chicken-4 (import scheme chicken data-structures posix ports extras (prefix mtargs args:) srfi-1 ;; system-information )) (chicken-5 (import scheme chicken.base chicken.string chicken.time chicken.time.posix chicken.port chicken.process-context chicken.process-context.posix srfi-1 (prefix mtargs args:)) (define setenv set-environment-variable!) )) ;;====================================================================== ;; debug stuff ;;====================================================================== (define verbosity (make-parameter '())) (define *default-log-port* (current-error-port)) (define debug:print-logger (make-parameter #f)) ;; set to a proc to call on every logging print (define (debug:setup) (let ((debugstr (or (args:get-arg "-debug") (args:get-arg "-debug-noprop") (get-environment-variable "MT_DEBUG_MODE")))) (verbosity (debug:calc-verbosity debugstr 'q)) (debug:check-verbosity (verbosity) debugstr) ;; if we were handed a bad verbosity rule then we will override it with 1 and continue (if (not (verbosity))(verbosity 1)) (if (and (not (args:get-arg "-debug-noprop")) (or (args:get-arg "-debug") (not (get-environment-variable "MT_DEBUG_MODE")))) (setenv "MT_DEBUG_MODE" (if (list? (verbosity)) (string-intersperse (map conc (verbosity)) ",") (conc (verbosity))))))) ;; check verbosity, #t is ok (define (debug:check-verbosity verbosity vstr) (if (not (or (number? verbosity) (list? verbosity))) (begin (print "ERROR: Invalid debug value \"" vstr "\"") #f) #t)) ;;====================================================================== ;; (define (debug:print . params) #f) ;; (define (debug:print-info . params) #f) ;; ;; (define (set-functions dbgp dbgpinfo) ;; (set! debug:print dbgp) ;; (set! debug:print-info dbgpinfo)) ;;====================================================================== ;; this was cached based on results from profiling but it turned out the profiling ;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching ;; in for now but can probably take it out later. ;; (define (debug:calc-verbosity vstr arg) ;; arg is 'v (verbose) or 'q (quiet) (let* ((res (cond ((number? vstr) vstr) ((not (string? vstr)) 1) ;; ((string-match "^\\s*$" vstr) 1) (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ","))))) (cond ((> (length debugvals) 1) debugvals) ((> (length debugvals) 0)(car debugvals)) (else 1)))) ((eq? arg 'v) 2) ;; verbose ((eq? arg 'q) 0) ;; quiet (else 1)))) (verbosity res) res)) ;;====================================================================== ;; check verbosity, #t is ok #;(define (debug-check-verbosity verbosity vstr) (if (not (or (number? verbosity) (list? verbosity))) (begin (print "ERROR: Invalid debug value \"" vstr "\"") #f) #t)) (define (debug:debug-mode n) (let* ((vb (verbosity))) (cond ((and (number? vb) ;; number number (number? n)) (<= n vb)) ((and (list? vb) ;; list number (number? n)) (member n vb)) ((and (list? vb) ;; list list (list? n)) (not (null? (lset-intersection! eq? vb n)))) ((and (number? vb) (list? n)) (member vb n)) (else #f)))) ;; (define (debug:handle-remote-logging params) ;; (if (debug:print-logger) ;; NOTE: turn params into string to keep things simple for now ;; ((debug:print-logger)(conc "REMOTE ("(get-host-name)", pid="(current-process-id)") " ;; (string-intersperse (map conc params) " ") "; " ;; (string-intersperse (command-line-arguments) " "))))) (define debug:enable-timestamp (make-parameter #t)) (define (debug:timestamp) (if (debug:enable-timestamp) (conc (time->string (seconds->local-time (current-seconds)) "%H:%M:%S") " ") "")) (define (debug:print n e . params) (if (debug:debug-mode n) (with-output-to-port (or e (current-error-port)) (lambda () ;; (if *logging* ;; (db:log-event (apply conc params)) (apply print (debug:timestamp) params) ;; (debug:handle-remote-logging params) ))) #t ;; only here to make remote stuff happy. It'd be nice to fix that ... ) (define (debug:print-error n e . params) ;; normal print (if (debug:debug-mode n) (with-output-to-port (if (port? e) e (current-error-port)) (lambda () (apply print "ERROR: " (debug:timestamp) params) ;; (debug:handle-remote-logging (cons "ERROR: " params)) ))) ;; pass important messages to stderr (if (and (eq? n 0)(not (eq? e (current-error-port)))) (with-output-to-port (current-error-port) (lambda () (apply print "ERROR: " (debug:timestamp) params) )))) (define (debug:print-info n e . params) (if (debug:debug-mode n) (with-output-to-port (if (port? e) e (current-error-port)) (lambda () (apply print "INFO: (" n ") "(debug:timestamp) params) ;; res) ;; (debug:handle-remote-logging (cons "INFO: " params)) )))) (define (debug:print-warn n e . params) (if (debug:debug-mode n) (with-output-to-port (if (port? e) e (current-error-port)) (lambda () (apply print "WARN: (" n ") " (debug:timestamp) params) ;; res) ;; (debug:handle-remote-logging (cons "WARN: " params)) )))) ) |
Modified diff-report.scm from [722e4fdcd5] to [ce1fe2b5f1].
︙ | ︙ | |||
14 15 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 diff-report)) (declare (uses common)) (declare (uses rmt)) (include "common_records.scm") (use matchable) (use fmt) (use ducttape-lib) (define css "") | > > > > > > | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | ;; ;; 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 diff-report)) (declare (uses common)) (declare (uses debugprint)) (declare (uses rmt)) (declare (uses rmtmod)) (declare (uses commonmod)) (import commonmod rmtmod debugprint) (include "common_records.scm") (use matchable) (use fmt) (use ducttape-lib) (define css "") |
︙ | ︙ | |||
144 145 146 147 148 149 150 | #f)))) (define (diff:target+run-name->run-id target run-name) (let* ((keys (rmt:get-keys)) (target-parts (if target (string-split target "/") (map (lambda (x) "%") keys)))) (if (not (eq? (length keys) (length keys))) (begin | | | 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 | #f)))) (define (diff:target+run-name->run-id target run-name) (let* ((keys (rmt:get-keys)) (target-parts (if target (string-split target "/") (map (lambda (x) "%") keys)))) (if (not (eq? (length keys) (length keys))) (begin (debug:print 0 *default-log-port* "Error: Target ("target") item count does not match fields count target tokens="target-parts" fields="keys) #f) (let* ((target-map (zip keys target-parts)) (qry-res (rmt:get-runs run-name 1 0 target-map))) (if (eq? 2 (vector-length qry-res)) (let ((first-ent (vector-ref qry-res 1))) (if (> (length first-ent) 0) |
︙ | ︙ | |||
382 383 384 385 386 387 388 | ) (if html-output-file (with-output-to-file html-output-file (lambda () (print html-body)))) (when (and email-recipients-list (> (length email-recipients-list) 0)) (sendmail (string-join email-recipients-list ",") email-subject html-body use_html: #t)) html-body)) | < < < < < < < < < < < < | | | | | 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 | ) (if html-output-file (with-output-to-file html-output-file (lambda () (print html-body)))) (when (and email-recipients-list (> (length email-recipients-list) 0)) (sendmail (string-join email-recipients-list ",") email-subject html-body use_html: #t)) html-body)) (define (do-diff-report src-target src-runname dest-target dest-runname html-file to-list-raw) (let* (;;(src-target "nope%") ;;(src-runname "all57") ;;(dest-target "%") ;;(dest-runname "all60") (src-run-id (diff:target+run-name->run-id src-target src-runname)) (dest-run-id (diff:target+run-name->run-id dest-target dest-runname)) ;(html-file "/tmp/bjbarcla/zippy.html") (to-list (if (string? to-list-raw) (string-split to-list-raw ",:") #f)) ) (cond ((not src-run-id) (debug:print 0 *default-log-port* "No match for source target/runname="src-target"/"src-runname) (debug:print 0 *default-log-port* "Cannot proceed.") #f) ((not dest-run-id) (debug:print 0 *default-log-port* "No match for source target/runname="dest-target"/"dest-runname) (debug:print 0 *default-log-port* "Cannot proceed.") #f) (else (diff:deliver-diff-report src-run-id dest-run-id email-recipients-list: to-list html-output-file: html-file))))) |
Modified docs/Makefile from [c01320f2b0] to [fc2e46e5a1].
︙ | ︙ | |||
31 32 33 34 35 36 37 | fossil add html/* megatest.pdf : megatest.lyx lyx -e pdf2 megatest.lyx pkts.pdf : pkts.dot dot -Tpdf pkts.dot -o pkts.pdf | > > > | 31 32 33 34 35 36 37 38 39 40 | fossil add html/* megatest.pdf : megatest.lyx lyx -e pdf2 megatest.lyx pkts.pdf : pkts.dot dot -Tpdf pkts.dot -o pkts.pdf stepwise.pdf : stepwise-rpc-via-direct-and-tcp-or-http.dot dot stepwise-rpc-via-direct-and-tcp-or-http.dot -Tpdf -o stepwise.pdf |
Added docs/csirc version [ab27eade5c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (cond-expand (chicken-4 ;; chicken 4 stuff here (use readline) (current-input-port (make-readline-port)) (install-history-file #f "/.csi.history") ) (chicken-5 (import (chicken load)) (import (chicken format)) (import (chicken process-context)) (import (chicken process signal)) (load-verbose #f) (let () (unless (get-environment-variable "INSIDE_EMACS") (import breadline) (import breadline-scheme-completion) (history-file (format "~a/.csi_history" (get-environment-variable "HOME"))) (stifle-history! 10000) (completer-word-break-characters-set! "\"\'`;|(") (completer-set! scheme-completer) (basic-quote-characters-set! "\"|") (variable-bind! "blink-matching-paren" "on") (paren-blink-timeout-set! 200000) (let ((handler (signal-handler signal/int))) (set-signal-handler! signal/int (lambda (s) (cleanup-after-signal!) (reset-after-signal!) (handler s)))) (on-exit reset-terminal!) (current-input-port (make-readline-port)))) )) |
Modified docs/manual/Makefile from [759e8c25e6] to [4935d2a088].
︙ | ︙ | |||
35 36 37 38 39 40 41 42 43 44 45 46 47 48 | megatest_manual.html : megatest_manual.txt *.txt installation.txt *png *.dot asciidoc -b html5 -a icons -a iconsdir=$(DISPATH)/images/icons -a toc2 megatest_manual.txt # dos2unix megatest_manual.html megatest_manual.pdf : megatest_manual.txt *.txt *png *.dot a2x -a toc -f pdf megatest_manual.txt server.ps : server.dot dot -Tps server.dot > server.ps client.ps : client.dot dot -Tps client.dot > client.ps complex-itemmap.png : complex-itemmap.dot | > > > | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 | megatest_manual.html : megatest_manual.txt *.txt installation.txt *png *.dot asciidoc -b html5 -a icons -a iconsdir=$(DISPATH)/images/icons -a toc2 megatest_manual.txt # dos2unix megatest_manual.html megatest_manual.pdf : megatest_manual.txt *.txt *png *.dot a2x -a toc -f pdf megatest_manual.txt %.pdf : %.dot dot -Tpdf $*.dot -o$*.pdf server.ps : server.dot dot -Tps server.dot > server.ps client.ps : client.dot dot -Tps client.dot > client.ps complex-itemmap.png : complex-itemmap.dot |
︙ | ︙ |
Modified docs/manual/bisecting.png from [81573d185b] to [bd3e81c898].
cannot compute difference between binary files
Modified docs/manual/debugging.txt from [b59cfb8782] to [731079995f].
︙ | ︙ | |||
160 161 162 163 164 165 166 | ---------------------------------------------------------------------- include::megatest-test-stages.dot[] ---------------------------------------------------------------------- .How to check variable values and inspect logs at each stage [width="80%",cols="<,2m,2m",frame="topbot",options="header"] |====================== | | | | | 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 | ---------------------------------------------------------------------- include::megatest-test-stages.dot[] ---------------------------------------------------------------------- .How to check variable values and inspect logs at each stage [width="80%",cols="<,2m,2m",frame="topbot",options="header"] |====================== |Stage | How to inspect | Watch for or try ... |A: post config processing | megatest -show-config -target your/target | #f (failed var processing) |B: post runconfig | megatest -show-runconfig -target your/target | Add -debug 0,9 to see which file your settings come from |C: processing testconfigs | inspect output from "megatest -run ..." | Messages indicating issues process configs, dependency problems |D: process testconfig for test launch | inspect output from megatest runner | Zero items (items expansion yielded no items) |E,F: launching test | start test xterm, look at mt_launch.log | Did your batch system accept the job? Has the job landed on a machine? |G: starting test | look at your batch systems logs for the process | Did the megatest -execute process start and run? Extract the "megatest -execute ..." command and run it from your xterm. |H,H1,H2: step exectution | look at <stepname>.log, <stepname>.html and your own internal logs | Do you have sufficiently tight logpro rules? You must always have a "required" rule! |====================== Bisecting megatest.csh/sh ^^^^^^^^^^^^^^^^^^^^^^^^^ Sometimes finding the environment variable that is causing the problem |
︙ | ︙ | |||
230 231 232 233 234 235 236 237 238 239 240 241 242 243 | ----------------- When this test is run an xterm will pop up. In that xterm the environment is exactly that in which the script "getcellnames.sh" would run. You can now debug the script to find out why it isn't working as expected. NOTE: This technique can be very helpful in debugging running of EDA tools in Perl, Ruby, Python or tcl scripts: .Perl example .............................. some_code(); $cmdline="virtuoso -some-switches and params ..."; print "$cmdline"; # print the command line so you can paste it into the xterm that pops up | > | 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 | ----------------- When this test is run an xterm will pop up. In that xterm the environment is exactly that in which the script "getcellnames.sh" would run. You can now debug the script to find out why it isn't working as expected. Similarly in a script just call the xterm. NOTE: This technique can be very helpful in debugging running of EDA tools in Perl, Ruby, Python or tcl scripts: .Perl example .............................. some_code(); $cmdline="virtuoso -some-switches and params ..."; print "$cmdline"; # print the command line so you can paste it into the xterm that pops up |
︙ | ︙ | |||
268 269 270 271 272 273 274 | ................... In scripts just insert the commands, this example helps you identify if "some commands ..." changed any environment variables.: .myscript.sh .............................. | | | > > | > > > > > | > > > > | > | > > > > > > | > | 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 | ................... In scripts just insert the commands, this example helps you identify if "some commands ..." changed any environment variables.: .myscript.sh .............................. env | sort > somefile-before.log some commands ... env | sort > somefile-after.log .............................. .Use meld to examine the differences .............................. meld somefile-before.log somefile-after.log .............................. Oneshot Modifying a Variable ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ To try various values for a variable without mutating the current value .within a bash shell .............................. SOMEVAR=123 runcmd.sh .............................. .within csh .............................. (setenv SOMEVAR 123;runcmd.sh) # OR env SOMEVAR=123 runcmd.sh .............................. Capturing output from a command ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ .Use the "script" utility .............................. script -c "virtuoso -params and switches ..." .............................. |
Modified docs/manual/megatest-test-stages.png from [e53ee8abbe] to [81fa066a5e].
cannot compute difference between binary files
Modified docs/manual/megatest_manual.html from [f34de80915] to [b4f1973471].
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 9.0.0rc1"> <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 100 101 102 103 104 105 | ul, ol, li > p { margin-top: 0; } ul > li { color: #aaa; } ul > li > * { color: black; } .monospaced, code, pre { font-family: "Courier New", Courier, monospace; font-size: inherit; color: navy; padding: 0; margin: 0; } pre { white-space: pre-wrap; } #author { color: #527bbd; font-weight: bold; font-size: 1.1em; } #email { |
︙ | ︙ | |||
214 215 216 217 218 219 220 | div.exampleblock > div.content { border-left: 3px solid #dddddd; padding-left: 0.5em; } div.imageblock div.content { padding-left: 0; } | | | 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 | 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; vertical-align: text-bottom; } a.image:visited { color: white; } dl { margin-top: 0.8em; margin-bottom: 0.8em; } dt { |
︙ | ︙ | |||
410 411 412 413 414 415 416 | /* * xhtml11 specific * * */ | < < < < < < | < < < < < < | 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 | /* * xhtml11 specific * * */ div.tableblock { margin-top: 1.0em; margin-bottom: 1.5em; } div.tableblock > table { border: 3px solid #527bbd; } thead, p.table.header { font-weight: bold; color: #527bbd; } p.table { margin-top: 0; } /* Because the table frame attribute is overridden by CSS in most browsers. */ div.tableblock > table[frame="void"] { border-style: none; } div.tableblock > table[frame="hsides"] { border-left-style: none; border-right-style: none; } div.tableblock > table[frame="vsides"] { border-top-style: none; border-bottom-style: none; } /* * html5 specific * * */ table.tableblock { margin-top: 1.0em; margin-bottom: 1.5em; } thead, p.tableblock.header { font-weight: bold; color: #527bbd; |
︙ | ︙ | |||
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 { | > > | 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 | 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 { |
︙ | ︙ | |||
2072 2073 2074 2075 2076 2077 2078 | <col style="width:20%;"> <col style="width:40%;"> <col style="width:40%;"> <thead> <tr> <th class="tableblock halign-left valign-top" >Stage </th> <th class="tableblock halign-left valign-top" > How to inspect </th> | | | 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 | <col style="width:20%;"> <col style="width:40%;"> <col style="width:40%;"> <thead> <tr> <th class="tableblock halign-left valign-top" >Stage </th> <th class="tableblock halign-left valign-top" > How to inspect </th> <th class="tableblock halign-left valign-top" > Watch for or try …</th> </tr> </thead> <tbody> <tr> <td class="tableblock halign-left valign-top" ><p class="tableblock">A: post config processing</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">megatest -show-config -target your/target</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">#f (failed var processing)</p></td> |
︙ | ︙ | |||
2104 2105 2106 2107 2108 2109 2110 | <td class="tableblock halign-left valign-top" ><p class="tableblock">E,F: launching test</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">start test xterm, look at mt_launch.log</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">Did your batch system accept the job? Has the job landed on a machine?</p></td> </tr> <tr> <td class="tableblock halign-left valign-top" ><p class="tableblock">G: starting test</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">look at your batch systems logs for the process</p></td> | | | 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 | <td class="tableblock halign-left valign-top" ><p class="tableblock">E,F: launching test</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">start test xterm, look at mt_launch.log</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">Did your batch system accept the job? Has the job landed on a machine?</p></td> </tr> <tr> <td class="tableblock halign-left valign-top" ><p class="tableblock">G: starting test</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">look at your batch systems logs for the process</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">Did the megatest -execute process start and run? Extract the "megatest -execute …" command and run it from your xterm.</p></td> </tr> <tr> <td class="tableblock halign-left valign-top" ><p class="tableblock">H,H1,H2: step exectution</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">look at <stepname>.log, <stepname>.html and your own internal logs</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">Do you have sufficiently tight logpro rules? You must always have a "required" rule!</p></td> </tr> </tbody> |
︙ | ︙ | |||
2164 2165 2166 2167 2168 2169 2170 | DEBUG [system xterm] CELLNAME [system getcellnames.sh]</pre> </div></div> <div class="paragraph"><p>When this test is run an xterm will pop up. In that xterm the environment is exactly that in which the script "getcellnames.sh" would run. You can now debug the script to find out why it isn’t working as expected.</p></div> | | < < < < | < < | 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 | DEBUG [system xterm] CELLNAME [system getcellnames.sh]</pre> </div></div> <div class="paragraph"><p>When this test is run an xterm will pop up. In that xterm the environment is exactly that in which the script "getcellnames.sh" would run. You can now debug the script to find out why it isn’t working as expected.</p></div> <div class="paragraph"><p>Similarly in a script just call the xterm. NOTE: This technique can be very helpful in debugging running of EDA tools in Perl, Ruby, Python or tcl scripts:</p></div> <div class="literalblock"> <div class="title">Perl example</div> <div class="content monospaced"> <pre>some_code(); $cmdline="virtuoso -some-switches and params ..."; print "$cmdline"; # print the command line so you can paste it into the xterm that pops up system("xterm"); # this line is added for the debug and removed when done |
︙ | ︙ | |||
2205 2206 2207 2208 2209 2210 2211 | [system env | sort > stagename.log]</pre> </div></div> <div class="paragraph"><p>In scripts just insert the commands, this example helps you identify if "some commands …" changed any environment variables.:</p></div> <div class="literalblock"> <div class="title">myscript.sh</div> <div class="content monospaced"> | | | > | > | > > > > > | > | > > > > | > > > > > > | 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 | [system env | sort > stagename.log]</pre> </div></div> <div class="paragraph"><p>In scripts just insert the commands, this example helps you identify if "some commands …" changed any environment variables.:</p></div> <div class="literalblock"> <div class="title">myscript.sh</div> <div class="content monospaced"> <pre>env | sort > somefile-before.log some commands ... env | sort > somefile-after.log</pre> </div></div> <div class="literalblock"> <div class="title">Use meld to examine the differences</div> <div class="content monospaced"> <pre>meld somefile-before.log somefile-after.log</pre> </div></div> </div> <div class="sect3"> <h4 id="_oneshot_modifying_a_variable">Oneshot Modifying a Variable</h4> <div class="paragraph"><p>To try various values for a variable without mutating the current value</p></div> <div class="literalblock"> <div class="title">within a bash shell</div> <div class="content monospaced"> <pre>SOMEVAR=123 runcmd.sh</pre> </div></div> <div class="literalblock"> <div class="title">within csh</div> <div class="content monospaced"> <pre>(setenv SOMEVAR 123;runcmd.sh) # OR env SOMEVAR=123 runcmd.sh</pre> </div></div> </div> <div class="sect3"> <h4 id="_capturing_output_from_a_command">Capturing output from a command</h4> <div class="literalblock"> <div class="title">Use the "script" utility</div> <div class="content monospaced"> <pre>script -c "virtuoso -params and switches ..."</pre> </div></div> </div> </div> </div> </div> <div class="sect1"> <h2 id="_how_to_do_things">How To Do Things</h2> <div class="sectionbody"> |
︙ | ︙ | |||
2585 2586 2587 2588 2589 2590 2591 | </div></div> </div> <div class="sect2"> <h3 id="_trim_trailing_spaces">Trim trailing spaces</h3> <div class="admonitionblock"> <table><tr> <td class="icon"> | | | 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 | </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="/usr/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] |
︙ | ︙ | |||
2902 2903 2904 2905 2906 2907 2908 | <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"> | | | 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 | <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="/usr/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"> |
︙ | ︙ | |||
3256 3257 3258 3259 3260 3261 3262 | testname1/itempath A comment about why it was waived testname2 A comment for a non-itemized test</pre> </div></div> </div> </div> <div class="sect2"> <h3 id="_ezsteps">Ezsteps</h3> | < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < | < < < | < < < < < < < < | 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 | testname1/itempath A comment about why it was waived testname2 A comment for a non-itemized test</pre> </div></div> </div> </div> <div class="sect2"> <h3 id="_ezsteps">Ezsteps</h3> <div class="listingblock"> <div class="title">Example ezsteps with logpro rules</div> <div class="content monospaced"> <pre>[ezsteps] lookittmp ls /tmp [logpro] lookittmp ;; Note: config file format supports multi-line entries where leading whitespace is removed from each line ;; a blank line indicates the end of the block of text (expect:required in "LogFileBody" > 0 "A file name that should never exist!" #/This is a awfully stupid file name that should never be found in the temp dir/)</pre> </div></div> <div class="paragraph"><p>To transfer the environment to the next step you can do the following: # if your upstream file is csh you can force csh like this # if your upstream is bash loadenv source $REF/ourenviron.sh</p></div> <div class="listingblock"> <div class="title">Propagate environment to next step</div> <div class="content monospaced"> <pre>$MT_MEGATEST -env2file .ezsteps/${stepname}</pre> </div></div> </div> <div class="sect2"> <h3 id="_scripts">Scripts</h3> <div class="listingblock"> <div class="title">Specifying scripts inline (best used for only simple scripts)</div> <div class="content monospaced"> <pre>[scripts] |
︙ | ︙ | |||
3478 3479 3480 3481 3482 3483 3484 | <div class="content monospaced"> <pre>[triggers] COMPLETED/ xterm -e bash -s --</pre> </div></div> <div class="admonitionblock"> <table><tr> <td class="icon"> | | | 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 | <div class="content monospaced"> <pre>[triggers] COMPLETED/ xterm -e bash -s --</pre> </div></div> <div class="admonitionblock"> <table><tr> <td class="icon"> <img src="/usr/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 |
︙ | ︙ | |||
3815 3816 3817 3818 3819 3820 3821 | </div> </div> </div> <div id="footnotes"><hr></div> <div id="footer"> <div id="footer-text"> Version 1.5<br> | | > | 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 | </div> </div> </div> <div id="footnotes"><hr></div> <div id="footer"> <div id="footer-text"> Version 1.5<br> Last updated 2023-01-23 11:18:29 EST </div> </div> </body> </html> |
Modified docs/manual/megatest_manual.pdf from [04c5fe16a4] to [ab362656bb].
cannot compute difference between binary files
Modified docs/manual/reference.txt from [624b8fd08d] to [7adc3533c3].
︙ | ︙ | |||
722 723 724 725 726 727 728 | testname1/itempath A comment about why it was waived testname2 A comment for a non-itemized test --------------------------- Ezsteps ~~~~~~~ | < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < | < | < < < | < | < < < < < < < < < < < < < < < < < < < < < | 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 | testname1/itempath A comment about why it was waived testname2 A comment for a non-itemized test --------------------------- Ezsteps ~~~~~~~ .Example ezsteps with logpro rules ----------------- [ezsteps] lookittmp ls /tmp [logpro] lookittmp ;; Note: config file format supports multi-line entries where leading whitespace is removed from each line ;; a blank line indicates the end of the block of text (expect:required in "LogFileBody" > 0 "A file name that should never exist!" #/This is a awfully stupid file name that should never be found in the temp dir/) ----------------- To transfer the environment to the next step you can do the following: # if your upstream file is csh you can force csh like this # if your upstream is bash loadenv source $REF/ourenviron.sh .Propagate environment to next step ---------------------------- $MT_MEGATEST -env2file .ezsteps/${stepname} ---------------------------- Scripts ~~~~~~~ .Specifying scripts inline (best used for only simple scripts) ---------------------------- [scripts] |
︙ | ︙ |
Modified docs/manual/server.dot from [3e029f5fe5] to [0db71acc28].
︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 | // 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/>. digraph G { subgraph cluster_1 { node [style=filled,shape=box]; | > > > > > > > | < > > | | > > | | | | | | > > | < < | | < < | < > | < | < < > | > > | > | | | | | | < | | < | < < | | | < > > | < < < < | | > | > | < < < | | 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 | // 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/>. digraph G { label = "Server Start Sequences"; color=brown; rankdir="TB"; subgraph cluster_1 { label="Find Prime Main Server"; node [style=filled,shape=box]; START; HaveServ [label="Look at .servinfo\nfiles for prime main"]; AskPrime [label="Ask Prime for main"]; PingPrime [label="Ping Prime"]; AskPrime [label="Ask .servinfo prime for server"]; StartServ [label="Launch Server Process for main.db"]; START -> HaveServ; HaveServ -> PingPrime; PingPrime -> AskPrime [label="Got response"]; PingPrime -> StartServ [label="No reponse"]; HaveServ -> StartServ [label="No files"]; StartServ -> "Delay 2s" -> START; AskPrime -> DONE; } subgraph cluster_2 { label="Starting non-prime server" node [style=filled,shape=box]; StartTCPServer [label="Start tcp server"]; FindPrimeMain [label="Find Prime Main Server"]; RegisterProcessViaPrime [label="Register process via prime server"]; StartTCPServer -> FindPrimeMain -> START; DONE -> RegisterProcessViaPrime -> READY; } subgraph cluster_3 { label="Start Prime Main" node [style=filled,shape=box]; StartTCPServer_prime [label="Start tcp server"]; GetServInfoFiles [label="Get servinfo files"]; CreateServInfoFile [label="Create servinfo file"]; RegisterProcess [label="Register process in no-sync (direct access)"]; ValidateServInfoFiles [label="Validate servinfo files with ping\nremove any files which do not respond to ping"]; CheckHost [label="Verify that current host matches\nexisting servinfo files host"] StartTCPServer_prime -> GetServInfoFiles; GetServInfoFiles -> CreateServInfoFile [label="No servinfo\nfiles"]; GetServInfoFiles -> ValidateServInfoFiles; ValidateServInfoFiles -> CreateServInfoFile [label="No valid files"]; CreateServInfoFile -> GetServInfoFiles [label="servinfo file created"]; KeepRunning [label="READY"]; ValidateServInfoFiles -> CheckHost; CheckHost -> RegisterProcess [label="Have valid\nservinfo files and same host"]; RegisterProcess -> KeepRunning; CheckHost -> EXIT [label="Not same host"]; } } |
Modified docs/manual/server.png from [ae7d7ee58e] to [2c71aac137].
cannot compute difference between binary files
Modified docs/megatest-debug-tutorial.odp from [e618e203db] to [bfd2483cd2].
cannot compute difference between binary files
Added docs/megatest-training-1.odp version [3a112130cd].
cannot compute difference between binary files
Modified docs/megatest-training.odp from [f923ec026f] to [570b812b2b].
cannot compute difference between binary files
Added docs/reference/coping-with-the-tcp-time-wait-state-on-busy-linux-servers.pdf version [bb7c60045d].
cannot compute difference between binary files
Added docs/reference/networking-increasing-the-max-number-of-tcp-ip-connections.pdf version [c3bfe57256].
cannot compute difference between binary files
Added docs/reference/queues-dont-fix-overload.pdf version [938610cb6e].
cannot compute difference between binary files
Added docs/stepwise-rpc-via-direct-and-tcp-or-http.dot version [a96a45b2ca].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | // Copyright 2006-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/>. // digraph megatest_state_status { ranksep=0.05; // rankdir=LR node [shape=box,style=filled]; "START" -> "have_server"; "DONE" [label="ALL DONE"]; "send_request" -> "receive_response"; "receive_response" -> "DONE"; "have_server" -> "start_http_server" [label="no"]; subgraph cluster_start_server { label="Start Server"; "start_http_server" -> "create_servinfo_file"; "start_http_server" -> "enable_direct_mode"; "create_servinfo_file" -> "delay_60_sec"; "delay_60_sec" -> "set_up_tmp_cache"; "set_up_tmp_cache" -> "switch_mode_to_tmp"; } subgraph cluster_direct_access { label="Direct Access"; "direct_access" -> "touch_access_file"; "touch_access_file" -> "touch_host_pid_file"; "touch_host_pid_file" -> "count_host_pid_files"; "count_host_pid_files" -> "call_query_proc" [label="count < 5"]; "wait_for_low_count_host_pid_files" [label="sleep 1"]; "count_host_pid_files" -> "wait_for_low_count_host_pid_files"[label="count >= 5"]; "wait_for_low_count_host_pid_files" -> "count_host_pid_files"; "call_query_proc" -> "DONE"; } "have_server" -> "ping_server" [label="yes"]; "have_server" -> "direct_access" [label="no" ]; "ping_server" -> "send_request" [label="server alive"]; "ping_server" -> "remove_server_file" [label="server not alive"]; "remove_server_file" -> "START"; } // subgraph cluster_notstarted { // label="Not started"; // "NOT_STARTED FAILS" [ // label = "{ NOT_STARTED/FAILS |{ NO_ITEMS |<here> FAIL_PREREQ |<here> FAIL_TIMEOUT }}"; // shape= "record"; // ] // // "NOT_STARTED n/a" -> "LAUNCHED n/a" [label=" launch"]; // "NOT_STARTED WAIT" -> "LAUNCHED n/a" // // "NOT_STARTED n/a"; // "NOT_STARTED WAIT" [ // label = "{NOT_STARTED WAIT|{ NO_SLOTS | <here> WAIT_PREREQ}}"; // shape = "record"; // ] // // // struct3 [shape=record,label="hello\nworld |{ b |{c|<here> d|e}| f}| g | h"]; // // "NOT_STARTED n/a" -> "NOT_STARTED FAILS"; // "NOT_STARTED n/a" -> "NOT_STARTED WAIT"; // // "RUNNING" [ // shape="record"; // label="{RUNNING|{n/a|<here> PASS |<here> FAIL}}"; // ] // // "COMPLETED" [ // shape="record"; // label = "{COMPLETED|{PASS | SKIP | WAIVED | FAIL | CHECK| ABORT}}"; // ] // // // "RUNNING" -> "COMPLETED"; // "RUNNING" -> "INCOMPLETE" [label="test dead for > 24hrs"]; // // // "LAUNCHED n/a" -> "REMOTEHOSTSTART n/a" -> "RUNNING"; |
Modified env.scm from [c7d61e935d] to [84be7d5a91].
︙ | ︙ | |||
15 16 17 18 19 20 21 22 23 24 25 | ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit env)) (use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables) (define (env:open-db fname) | > > > > > > < < | | | | | | | | 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 | ;; ;; 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 env)) (declare (uses debugprint)) (declare (uses mtargs)) (import (prefix mtargs args:) debugprint) (use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables) (define (env:open-db fname) (let* ((db-exists (common:file-exists? fname)) (db (open-database fname))) (if (not db-exists) (begin (exec (sql db "CREATE TABLE envvars ( id INTEGER PRIMARY KEY, context TEXT NOT NULL, var TEXT NOT NULL, val TEXT NOT NULL, CONSTRAINT envvars_constraint UNIQUE (context,var))")))) (set-busy-handler! db (busy-timeout 10000)) db)) ;; save vars in given context, this is NOT incremental by default ;; (define (env:save-env-vars db context #!key (incremental #f)(vardat #f)) (with-transaction |
︙ | ︙ | |||
78 79 80 81 82 83 84 | (env:merge-path-envvar sep (hash-table-ref result var) val)) val))))) (sql db "SELECT var,val FROM envvars WHERE context=?") context)) contexts) result)) | < < < < < < < < < < < < < < < < < < < < < < < | 82 83 84 85 86 87 88 89 90 91 92 93 94 95 | (env:merge-path-envvar sep (hash-table-ref result var) val)) val))))) (sql db "SELECT var,val FROM envvars WHERE context=?") context)) contexts) result)) ;; get list of removed variables between two contexts ;; (define (env:get-removed db contexta contextb) (let ((result (make-hash-table))) (query (for-each-row (lambda (row) |
︙ | ︙ |
Modified ezsteps.scm from [0b0178b127] to [00800cd5a5].
︙ | ︙ | |||
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/>. ;; ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') | < < < > > | | > > > > > > > > < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < | < < < < < < < < < < < < < < | | | | | > | < | < < | < < < | | | | 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 | ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') (declare (unit ezsteps)) (declare (uses db)) (declare (uses common)) (declare (uses debugprint)) (declare (uses items)) (declare (uses runconfig)) (declare (uses commonmod)) (declare (uses rmtmod)) (declare (uses mtargs)) (use srfi-1 posix regex srfi-69 directory-utils call-with-environment-variables posix-extras z3 csv typed-records pathname-expand matchable) (import commonmod debugprint rmtmod (prefix mtargs args:)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") ;;(rmt:get-test-info-by-id run-id test-id) -> testdat ;; TODO: deprecate me in favor of ezsteps.scm ;; (define (ezsteps:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat) (let* ((stepname (car ezstep)) ;; do stuff to run the step (stepinfo (cadr ezstep)) ;; (let ((info (cadr ezstep))) ;; (if (proc? info) "" info))) ;; (stepproc (let ((info (cadr ezstep))) ;; (if (proc? info) info #f))) (stepparts (string-match (regexp "^(\\{([^\\}\\{]*)\\}\\s*|)(.*)$") stepinfo)) (stepparams (if (and (list? stepparts) (> (length stepparts) 1)) (list-ref stepparts 2) #f)) ;; for future use, {VAR=1,2,3}, run step for each (paramparts (if (string? stepparams) (map (lambda (x)(string-split x "=")) (string-split-fields "[^;]*=[^;]*" stepparams)) '())) (subrun (alist-ref "subrun" paramparts equal?)) (stepcmd (if (and (list? stepparts) (> (length stepparts) 2)) (list-ref stepparts 3) (conc "# error, no command for step "stepname))) (script "") ; "#!/bin/bash\n") ;; yep, we depend on bin/bash FIXME!!!\ (logpro-file (conc stepname ".logpro")) (html-file (conc stepname ".html")) (dat-file (conc stepname ".dat")) (tconfig-logpro (configf:lookup testconfig "logpro" stepname)) (logpro-used (common:file-exists? logpro-file)) (mtexepath (common:get-megatest-exe-path))) (setenv "MT_STEP_NAME" stepname) (hash-table-set! all-steps-dat stepname `((params . ,paramparts))) (debug:print 0 *default-log-port* "stepparts: " stepparts ", stepparams: " stepparams ", paramparts: " paramparts ", subrun: " subrun ", stepcmd: " stepcmd) (if (and tconfig-logpro (not logpro-used)) ;; no logpro file found but have a defn in the testconfig (begin (with-output-to-file logpro-file (lambda () (print ";; logpro file extracted from testconfig\n" ";;") (print tconfig-logpro))) (set! logpro-used #t))) ;; NB// can safely assume we are in test-area directory (debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts " stepparams: " stepparams " stepcmd: " stepcmd) ;; ;; first source the previous environment ;; (let ((prev-env (conc ".ezsteps/" prevstep (if (string-search (regexp "csh") ;; (get-environment-variable "SHELL")) ".csh" ".sh")))) ;; (if (and prevstep (common:file-exists? prev-env)) ;; (set! script (conc script "source " prev-env)))) ;; call the command using mt_ezstep ;; (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "x") " " stepcmd)) (debug:print 4 *default-log-port* "script: " script) (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f) ;; now launch the actual process (call-with-environment-variables (list (cons "PATH" mtexepath)) (lambda () ;; (process-run "/bin/bash" "-c" "exec ls -l /tmp/foobar > /tmp/delme-more.log 2>&1") (let* ((cmd (conc stepcmd " > " stepname ".log 2>&1")) ;; >outfile 2>&1 (pid #f)) (let ((proc (lambda () (set! pid (process-run "/bin/bash" (list "-c" cmd)))))) (if subrun (begin (debug:print-info 0 *default-log-port* "Running "cmd" without MT_.* environment variables.") (common:without-vars proc "^MT_.*")) (proc))) (with-output-to-file "Makefile.ezsteps" (lambda () (print stepname ".log :") (print "\t" cmd) (if (common:file-exists? (conc stepname ".logpro")) |
︙ | ︙ | |||
236 237 238 239 240 241 242 | ((and (eq? process-exit-status 2) logpro-used) 'warn) ;; logpro 2 = warnings ((and (eq? process-exit-status 3) logpro-used) 'check) ;; logpro 3 = check ((and (eq? process-exit-status 4) logpro-used) 'waived) ;; logpro 4 = waived ((and (eq? process-exit-status 5) logpro-used) 'abort) ;; logpro 5 = abort ((and (eq? process-exit-status 6) logpro-used) 'skip) ;; logpro 6 = skip ((eq? process-exit-status 0) 'pass) ;; logpro 0 = pass (else 'fail))) | | > | > > > > | | < < < < | 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 | ((and (eq? process-exit-status 2) logpro-used) 'warn) ;; logpro 2 = warnings ((and (eq? process-exit-status 3) logpro-used) 'check) ;; logpro 3 = check ((and (eq? process-exit-status 4) logpro-used) 'waived) ;; logpro 4 = waived ((and (eq? process-exit-status 5) logpro-used) 'abort) ;; logpro 5 = abort ((and (eq? process-exit-status 6) logpro-used) 'skip) ;; logpro 6 = skip ((eq? process-exit-status 0) 'pass) ;; logpro 0 = pass (else 'fail))) (overall-status (cond ((eq? (launch:einf-rollup-status exit-info) 2) 'warn) ;; rollup-status (vector-ref exit-info 3) ((eq? (launch:einf-rollup-status exit-info) 3) 'check) ((eq? (launch:einf-rollup-status exit-info) 4) 'waived) ((eq? (launch:einf-rollup-status exit-info) 5) 'abort) ((eq? (launch:einf-rollup-status exit-info) 6) 'skip) ((eq? (launch:einf-rollup-status exit-info) 0) 'pass) (else 'fail))) (next-status (common:worse-status-sym this-step-status overall-status)) (next-state ;; "RUNNING") ;; WHY WAS THIS CHANGED TO NOT USE (null? tal) ?? (cond ((null? tal) ;; more to run? "COMPLETED") (else "RUNNING")))) (debug:print 4 *default-log-port* "Exit value received: " (launch:einf-exit-code exit-info) " logpro-used: " logpro-used " this-step-status: " this-step-status " overall-status: " overall-status |
︙ | ︙ |
Deleted fs-transport.scm version [d1050dcefe].
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Modified genexample.scm from [c6a2ab2853] to [1c75f5d6f9].
︙ | ︙ | |||
15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | ;; ;; 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 | > > > > > > > | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | ;; ;; 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)) (declare (uses mtargs)) (declare (uses debugprint)) (declare (uses rmtmod)) (use posix regex matchable) (import (prefix mtargs args:) rmtmod debugprint) (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 |
︙ | ︙ |
Modified gutils.scm from [94030f1a6e] to [455c3c7ee1].
|
| | | 1 2 3 4 5 6 7 8 | ';;====================================================================== ;; 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 |
︙ | ︙ | |||
81 82 83 84 85 86 87 | (case (string->symbol status) ((CLEAN-FAIL CLEAN-CHECK CLEAN-ABORT) (list "200 130 13" status)) ;; orange requested for these (else (list "60 235 63" status)))) ((DIRTY-BETTER) (list "160 255 153" status)) ((DIRTY-WORSE) (list "165 42 42" status)) ((BOTH-BAD) (list "180 33 49" status)) | | > > > | 81 82 83 84 85 86 87 88 89 90 91 92 | (case (string->symbol status) ((CLEAN-FAIL CLEAN-CHECK CLEAN-ABORT) (list "200 130 13" status)) ;; orange requested for these (else (list "60 235 63" status)))) ((DIRTY-BETTER) (list "160 255 153" status)) ((DIRTY-WORSE) (list "165 42 42" status)) ((BOTH-BAD) (list "180 33 49" status)) (else (list ;; "192 192 192" "222 222 221" state)))) |
Modified items.scm from [16328a4b96] to [faab56b546].
︙ | ︙ | |||
19 20 21 22 23 24 25 26 27 28 29 30 31 32 | ;; (define itemdat '((ripeness "green ripe overripe") ;; (temperature "cool medium hot") ;; (season "summer winter fall spring"))) (declare (unit items)) (declare (uses common)) (include "common_records.scm") ;; Puts out all combinations (define (process-itemlist hierdepth curritemkey itemlist) (let ((res '())) (if (not hierdepth) | > > > > | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | ;; (define itemdat '((ripeness "green ripe overripe") ;; (temperature "cool medium hot") ;; (season "summer winter fall spring"))) (declare (unit items)) (declare (uses common)) (declare (uses debugprint)) (declare (uses commonmod)) (import commonmod debugprint) (include "common_records.scm") ;; Puts out all combinations (define (process-itemlist hierdepth curritemkey itemlist) (let ((res '())) (if (not hierdepth) |
︙ | ︙ |
Modified keys.scm from [9fa2c0cfa5] to [2247f182f0].
︙ | ︙ | |||
17 18 19 20 21 22 23 24 | ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;;====================================================================== ;; Run keys, these are used to hierarchially organise tests and run areas ;;====================================================================== (use sqlite3 srfi-1 posix regex regex-case srfi-69) | > > > > > > | > < | > | 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 | ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;;====================================================================== ;; Run keys, these are used to hierarchially organise tests and run areas ;;====================================================================== (declare (unit keys)) (declare (uses common)) (declare (uses debugprint)) (declare (uses commonmod)) (declare (uses mtargs)) (use sqlite3 srfi-1 posix regex regex-case srfi-69) (import (prefix sqlite3 sqlite3:) (prefix mtargs args:)) (import commonmod debugprint) (include "key_records.scm") (include "common_records.scm") (define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ... (string-intersperse keys ",")) |
︙ | ︙ |
Modified launch.scm from [940d39d039] to [e959ea01bb].
︙ | ︙ | |||
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 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 | ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== ;; launch a task - this runs on the originating host, tests themselves ;; ;;====================================================================== (declare (unit launch)) (declare (uses subrun)) (declare (uses common)) (declare (uses debugprint)) (declare (uses commonmod)) (declare (uses configf)) (declare (uses db)) (declare (uses rmtmod)) (declare (uses ezsteps)) ;; (declare (uses dbmod)) (declare (uses dbfile)) (declare (uses mtargs)) (use regex regex-case base64 sqlite3 srfi-18 directory-utils posix posix-extras z3 call-with-environment-variables csv hostinfo typed-records pathname-expand matchable) (import (prefix base64 base64:) (prefix sqlite3 sqlite3:) (prefix mtargs args:) ) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "megatest-fossil-hash.scm") (import commonmod rmtmod debugprint ;; dbmod dbfile) ;;====================================================================== ;; ezsteps ;;====================================================================== ;; ezsteps were going to be coded as ;; stepname[,predstep1,predstep2 ...] [{VAR1=first,second,third}] command to execute ;; BUT ;; now are ;; stepname {VAR=first,second,third ...} command ... ;; where the {VAR=first,second,third ...} is optional. ;; given an exit code and whether or not logpro was used calculate OK/BAD ;; return #t if we are ok, #f otherwise (define (steprun-good? logpro exitcode stepparms) (or (eq? exitcode 0) (and logpro (member exitcode '( 2 4 6))) (let* ((params (alist-ref 'params stepparms)) ;; get the params section (keep-going (if params (alist-ref "keep-going" params equal?) #f))) (debug:print 0 *default-log-port* "keep-going=" keep-going) (and keep-going (equal? (car keep-going) "yes"))))) |
︙ | ︙ | |||
157 158 159 160 161 162 163 | ;; 3. fix target ;; 4. fix runname ;; 5. fix testpatt or calculate it from contour ;; 6. launch the run ;; 7. roll up the run result and or roll up the logpro processed result (when (configf:lookup testconfig "subrun" "runwait") ;; we use runwait as the flag that a subrun is requested (subrun:initialize-toprun-test testconfig test-run-dir) | | < | < < | > > | | | | | | | | < | | | | | | | > > > | | | | | > > > | | | < < < > > > > | | | > | | | | > > > > | | > | > > > > > > > > > | 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 | ;; 3. fix target ;; 4. fix runname ;; 5. fix testpatt or calculate it from contour ;; 6. launch the run ;; 7. roll up the run result and or roll up the logpro processed result (when (configf:lookup testconfig "subrun" "runwait") ;; we use runwait as the flag that a subrun is requested (subrun:initialize-toprun-test testconfig test-run-dir) (let* ((mt-cmd (subrun:launch-cmd test-run-dir (configf:lookup testconfig "subrun" "runwait")))) (debug:print-info 0 *default-log-port* "Subrun command is \"" mt-cmd "\"") (set! ezsteps #t) ;; set the needed flag (set! ezstepslst (append (or ezstepslst '()) (list (list "subrun" (conc "{subrun=true} " mt-cmd))))))) ;; process the ezsteps (if ezsteps (let* ((all-steps-dat (make-hash-table))) ;; keep all the info around as stepname ==> alist; where 'params is the params list (add other stuff as needed) (if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps")) ;; if ezsteps was defined then we are sure to have at least one step but check anyway (if (not (> (length ezstepslst) 0)) (debug:print-error 0 *default-log-port* "ezsteps defined but ezstepslst is zero length") (let ((all-step-names (map car ezstepslst)) (status-file (file-open "ezsteps.status" (+ open/append open/wronly open/creat))) ) (setenv "MT_STEP_NAMES" (string-intersperse all-step-names " ")) (let loop ((ezstep (car ezstepslst)) (tal (cdr ezstepslst)) (prevstep #f)) (debug:print-info 0 *default-log-port* "Processing ezstep \"" (string-intersperse ezstep " ") "\"") ;; check exit-info (vector-ref exit-info 1) (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1) (let* ((logpro-used (ezsteps:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat)) (stepname (car ezstep)) (stepparms (hash-table-ref all-steps-dat stepname))) (setenv "MT_STEP_NAME" stepname) (pp (hash-table->alist all-steps-dat)) ;; if logpro-used read in the stepname.dat file (if (and logpro-used (common:file-exists? (conc stepname ".dat"))) (launch:load-logpro-dat run-id test-id stepname)) (file-write status-file (conc stepname " " (launch:einf-exit-code exit-info) "\n")) (if (steprun-good? logpro-used (launch:einf-exit-code exit-info) stepparms) (if (not (null? tal)) (loop (car tal) (cdr tal) stepname)) (debug:print 0 *default-log-port* "WARNING: step " (car ezstep) " failed. Stopping"))) (debug:print 0 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep))) (file-close status-file) ) )))))) (define (launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags) (let* ((update-period (string->number (or (configf:lookup *configdat* "setup" "test-stats-update-period") "60"))) (start-seconds (current-seconds)) (calc-minutes (lambda () (inexact->exact (round (- (current-seconds) start-seconds))))) (kill-tries 0)) ;; (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area) ;; (tests:set-full-meta-info test-id run-id (calc-minutes) work-area) (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10) (let loop ((minutes (calc-minutes)) (cpu-load (alist-ref 'adj-core-load (common:get-normalized-cpu-load #f))) (disk-free (get-df (current-directory))) (last-sync (current-seconds))) (let* ((over-time (> (current-seconds) (+ last-sync update-period))) (new-cpu-load (let* ((load (alist-ref 'adj-core-load (common:get-normalized-cpu-load #f))) (delta (abs (- load cpu-load)))) (if (> delta 0.1) ;; don't bother updating with small changes load #f))) (new-disk-free (let* ((df (if over-time ;; only get df every 30 seconds (get-df (current-directory)) disk-free)) (delta (abs (- df disk-free)))) (if (and (> df 0) (> (/ delta df) 0.1)) ;; (> delta 200) ;; ignore changes under 200 Meg df #f))) (do-sync (or new-cpu-load new-disk-free over-time)) ;; ;; MOVE THIS TO A FILE FLAG BASED APPROACH (FOR NOW) ;; ;; (test-info (rmt:get-test-state-status-by-id run-id test-id)) ;; (state (car test-info));; (db:test-get-state test-info)) ;; (status (cdr test-info));; (db:test-get-status test-info)) (killreq (file-exists? (conc work-area"/kill-test"))) ;; (equal? state "KILLREQ")) (kill-reason "no kill reason specified") (kill-job? #f)) ;; (common:telemetry-log "zombie" (conc "launch:monitor-job - decision time encountered at "(current-seconds)" with last-sync="last-sync" do-sync="do-sync" over-time="over-time" update-period="update-period)) (cond (killreq (set! kill-reason "KILLING TEST since received kill request (KILLREQ)") (set! kill-job? #t)) ((and runtlim (> (- (current-seconds) start-seconds) runtlim)) (set! kill-reason (conc "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" (- (current-seconds) start-seconds) " seconds, limit=" runtlim)) (set! kill-job? #t)) #;((equal? status "DEAD") ;; NEED ALTERNATIVE MECHANISM FOR THIS. (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f) (rmt:set-state-status-and-roll-up-items run-id test-id 'foo "RUNNING" "n/a" "was marked dead; really still running.") ;;(set! kill-reason "KILLING TEST because it was marked as DEAD by launch:handle-zombie-tests (might indicate really overloaded server or else overzealous setup.deadtime)") ;; MARK RUNNING (set! kill-job? #f))) (debug:print 4 *default-log-port* "cpu: " new-cpu-load " disk: " new-disk-free " last-sync: " last-sync " do-sync: " do-sync) ;; revisit logic in zombie handling. ;; (if (common:low-noise-print 600 "run zombie") ;; every five minutes is plenty (launch:handle-zombie-tests run-id)) (when do-sync ;; (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f) (let ((oup (open-output-file (conc work-area"/.run-logging-stats.csv") :append)) (csv (conc run-id","test-id","new-cpu-load","new-disk-free","(calc-minutes)))) (debug:print 0 *default-log-port* "Updating run log, csv="csv) (with-output-to-port oup (lambda () (print csv))) (close-output-port oup))) (if kill-job? (begin (debug:print-info 0 *default-log-port* "proceeding to kill test: "kill-reason) (mutex-lock! m) ;; NOTE: The pid can change as different steps are run. Do we need handshaking between this ;; section and the runit section? Or add a loop that tries three times with a 1/4 second ;; between tries? |
︙ | ︙ | |||
304 305 306 307 308 309 310 | (tests:test-set-status! run-id test-id "KILLED" "KILLED" (conc (args:get-arg "-m")" "kill-reason) #f)) ;; BB ADDED kill-reason -- confirm OK with Matt (begin (debug:print-error 0 *default-log-port* "Nothing to kill, pid1=" pid1 ", pid2=" pid2) (tests:test-set-status! run-id test-id "KILLED" "FAILED TO KILL" (conc (args:get-arg "-m")" "kill-reason) #f) ;; BB ADDED kill-reason -- confirm OK with Matt ))) (mutex-unlock! m) ;; no point in sticking around. Exit now. But run end of run before exiting? | | | | < | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (tests:test-set-status! run-id test-id "KILLED" "KILLED" (conc (args:get-arg "-m")" "kill-reason) #f)) ;; BB ADDED kill-reason -- confirm OK with Matt (begin (debug:print-error 0 *default-log-port* "Nothing to kill, pid1=" pid1 ", pid2=" pid2) (tests:test-set-status! run-id test-id "KILLED" "FAILED TO KILL" (conc (args:get-arg "-m")" "kill-reason) #f) ;; BB ADDED kill-reason -- confirm OK with Matt ))) (mutex-unlock! m) ;; no point in sticking around. Exit now. But run end of run before exiting? (launch:end-of-run-check run-id) (exit))) (if (hash-table-ref/default misc-flags 'keep-going #f) ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta (begin (thread-sleep! 6) ;; was 3 (loop (calc-minutes) (or new-cpu-load cpu-load) (or new-disk-free disk-free) (if do-sync (current-seconds) last-sync)))))) (tests:update-central-meta-info run-id test-id (commonmod:get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f))) ;; NOTE: Checking twice for keep-going is intentional ;; read testconfig and create .logpro and script files ;; - use #f for tconfigreg to re-read the testconfigs from disk ;; (define (launch:extract-scripts-logpro test-dir test-name item-path tconfigreg-in) (let* ((tconfigreg (or tconfigreg-in (tests:get-all))) (tconfig-fname (conc test-dir "/.testconfig")) (tconfig-tmpfile (conc tconfig-fname ".tmp")) (tconfig (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs))) (scripts (configf:get-section tconfig "scripts")) (logpros (configf:get-section tconfig "logpro"))) ;; create .testconfig file (configf:write-alist tconfig tconfig-tmpfile) (file-move tconfig-tmpfile tconfig-fname #t) (delete-file* ".final-status") ;; extract scripts from testconfig and write them to files in test run dir (for-each (lambda (scriptdat) (match scriptdat ((name content) (debug:print-info 2 *default-log-port* "Creating script "(current-directory)"/"name) (with-output-to-file name (lambda () (print content))) (change-file-mode name (bitwise-ior perm/irwxg perm/irwxu))) (else (debug:print-info 0 "Invalid script definiton found in [scripts] section of testconfig. \"" scriptdat "\"")))) scripts) ;; extract logpro from testconfig and write them to files in test run dir (for-each (lambda (logprodat) (match logprodat ((name content) (debug:print-info 2 *default-log-port* "Creating logpro file "(current-directory)"/"name ".logpro") (with-output-to-file (conc name".logpro") (lambda () (print content) ;; (change-file-mode name (bitwise-ior perm/irwxg perm/irwxu)) ))) (else (debug:print-info 0 "Invalid logpro definiton found in [logpro] section of testconfig. \"" logprodat "\"")))) logpros))) (define (launch:execute encoded-cmd) (let* ((cmdinfo (common:read-encoded-string encoded-cmd)) (tconfigreg #f)) (setenv "MT_CMDINFO" encoded-cmd) ;;(bb-check-path msg: "launch:execute incoming") (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed) |
︙ | ︙ | |||
362 363 364 365 366 367 368 | runscript ;; use unadultered if contains slashes (let ((fulln (conc work-area "/" runscript))) (if (and (common:file-exists? fulln) (file-execute-access? fulln)) fulln runscript))))) ;; assume it is on the path (check-work-area (lambda () | > | > > > > > > > | > > > | 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 | runscript ;; use unadultered if contains slashes (let ((fulln (conc work-area "/" runscript))) (if (and (common:file-exists? fulln) (file-execute-access? fulln)) fulln runscript))))) ;; assume it is on the path (check-work-area (lambda () ;; ;; NFS might not have propagated the ;; directory meta data to the run host - give it ;; time if needed ;; ;; alternatively - if nonfs is set, find a working ;; directory using [host-disks] and copy from ;; the homehost using rsync ;; (let loop ((count 0)) (if (or (common:directory-exists? work-area) (> count 10)) (change-directory work-area) (begin (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " work-area " not found") (thread-sleep! 10) (loop (+ count 1))))) (if (not (string=? (common:real-path work-area)(common:real-path (current-directory)))) (begin (debug:print 0 *default-log-port* "INFO: we are expecting to be in directory " work-area "\n" " but we are actually in the directory " (current-directory) "\n" " doing another change dir.") (change-directory work-area))) ;; spot check that the files in testpath are available. ;; Too often NFS delays cause problems here. (let ((files (glob (conc testpath "/*"))) (bad-files '())) (for-each (lambda (fullname) (let* ((fname (pathname-strip-directory fullname)) (targn (conc work-area "/" fname))) (if (not (file-exists? targn)) (set! bad-files (cons fname bad-files))))) files) (if (not (null? bad-files)) (begin (debug:print 0 *default-log-port* "INFO: test data from " testpath " not copied properly or filesystem problems causing data to not be found. Re-running the copy command.") (debug:print 0 *default-log-port* "INFO: missing files from " work-area ": " (string-intersperse bad-files ", ")) (launch:test-copy testpath work-area)))) ;; one more time, change to the work-area directory (change-directory work-area))) ) ;; let* (if contour (setenv "MT_CONTOUR" contour)) ;; immediated set some key variables from CMDINFO data, yes, these will be set again below ... ;; (setenv "MT_TESTSUITENAME" areaname) (setenv "MT_RUN_AREA_HOME" top-path) (set! *toppath* top-path) (change-directory *toppath*) ;; temporarily switch to the run area home (setenv "MT_TEST_RUN_DIR" work-area) |
︙ | ︙ | |||
428 429 430 431 432 433 434 | (set! tconfigreg (tests:get-all)) ;; mapping of testname => test source path (let ((sighand (lambda (signum) ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting (if (eq? signum signal/stop) (debug:print-error 0 *default-log-port* "attempt to STOP process. Exiting.")) (set! *time-to-exit* #t) | | | | | | 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 | (set! tconfigreg (tests:get-all)) ;; mapping of testname => test source path (let ((sighand (lambda (signum) ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting (if (eq? signum signal/stop) (debug:print-error 0 *default-log-port* "attempt to STOP process. Exiting.")) (set! *time-to-exit* #t) (debug:print 0 *default-log-port* "Received signal " signum ", cleaning up before exit (set this test to COMPLETED/ABORT) . Please wait...") (let ((th1 (make-thread (lambda () (debug:print 0 *default-log-port* "set test to COMPLETED/ABORT begin.") (rmt:test-set-state-status run-id test-id "COMPLETED" "ABORT" "received kill signal") (debug:print 0 *default-log-port* "set test to COMPLETED/ABORT complete.") (debug:print 0 *default-log-port* "Killed by signal " signum ". Exiting") (exit 1)))) (th2 (make-thread (lambda () (thread-sleep! 20) (debug:print 0 *default-log-port* "Done") (exit 4))))) (thread-start! th2) (thread-start! th1) |
︙ | ︙ | |||
466 467 468 469 470 471 472 | (db:test-get-host test-info) (begin (debug:print 0 *default-log-port* "ERROR: failed to find a record for test-id " test-id ", exiting.") (exit)))) (test-pid (db:test-get-process_id test-info))) (cond ;; -mrw- I'm removing KILLREQ from this list so that a test in KILLREQ state is treated as a "do not run" flag. | < < < | | | > | | | > | < < > > < < | < < < | < | < | < < < < | | > < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < | > > > > > > > > > > > > | > | > > > > > | | < < | > | > > | | | | | | < < | > | | > > | > > > > > > > > > > > > > > > > > > > > | | > | | | | > > > > > > | > | 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 | (db:test-get-host test-info) (begin (debug:print 0 *default-log-port* "ERROR: failed to find a record for test-id " test-id ", exiting.") (exit)))) (test-pid (db:test-get-process_id test-info))) (cond ;; -mrw- I'm removing KILLREQ from this list so that a test in KILLREQ state is treated as a "do not run" flag. ((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun (debug:print 0 *default-log-port* "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request") ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a") (rmt:general-call 'set-test-start-time run-id test-id) (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f) ) ;; prime it for running ((member (db:test-get-state test-info) '("RUNNING" "REMOTEHOSTSTART")) (if (process:alive-on-host? test-host test-pid) (debug:print-error 0 *default-log-port* "test state is " (db:test-get-state test-info) " and process " test-pid " is still running on host " test-host ", cannot proceed") (exit 1))) ((member (db:test-get-state test-info) '("COMPLETED")) ;; we do NOT want to re-run COMPLETED jobs. Mark as NOT_STARTED to run! (debug:print 0 *default-log-port* "test state is " (db:test-get-state test-info) ", cannot proceed") (debug:print 0 *default-log-port* "exiting with status 1") (exit 1)) ((not (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ"))) ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a") (rmt:general-call 'set-test-start-time run-id test-id) (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f)) (else ;; (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ")) (debug:print 0 *default-log-port* "test state is " (db:test-get-state test-info) ", cannot proceed") (debug:print 0 *default-log-port* "exiting with status 1") (exit 1)))) ;; cleanup prior execution's steps (rmt:delete-steps-for-test! run-id test-id) (debug:print 2 *default-log-port* "Executing " test-name " (id: " test-id ") on " (get-host-name)) (set! keys (rmt:get-keys)) ;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process ;; one of these is defunct/redundant ... (if (not (launch:setup force-reread: #t)) (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) ;; validate that the test run area is available (check-work-area) ;; still need to go back to run area home for next couple steps (change-directory *toppath*) ;; NOTE: Current order is to process runconfigs *before* setting the MT_ vars. This ;; seems non-ideal but could well break stuff ;; BUG? BUG? BUG? ;; CHANGE THIS: Do NOT read the runconfigs again - ONLY use the cached version (let ((rconfig (full-runconfigs-read)) ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target)))) (wconfig (read-config "waivers.config" #f #t sections: `( "default" ,target )))) ;; read the waivers config if it exists ;; Now have runconfigs data loaded, set environment vars (for-each (lambda (section) (for-each (lambda (varval) (let ((var (car varval)) (val (cadr varval))) (if (and (string? var)(string? val)) (begin (safe-setenv var (configf:eval-string-in-environment val))) ;; val) (debug:print-error 0 *default-log-port* "bad variable spec, " var "=" val)))) (configf:get-section rconfig section))) (list "default" target))) ;; NFS might not have propagated the directory meta data to the run host - give it time if needed (let loop ((count 0)) (if (or (common:file-exists? work-area) (> count 10)) (change-directory work-area) (begin (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " work-area " not found") (thread-sleep! 10) (loop (+ count 1))))) ;; now we can switch to the work-area? (change-directory work-area) (set! keyvals (keys:target->keyval keys target)) ;; apply pre-overrides before other variables. The pre-override vars must not ;; clobber things from the official sources such as megatest.config and runconfigs.config (if (string? set-vars) (let ((varpairs (string-split set-vars ","))) (debug:print 4 *default-log-port* "varpairs: " varpairs) (map (lambda (varpair) (let ((varval (string-split varpair "="))) (if (eq? (length varval) 2) (let ((var (car varval)) (val (cadr varval))) (debug:print 1 *default-log-port* "Adding pre-var/val " var " = " val " to the environment") (setenv var val))))) varpairs))) (for-each (lambda (varval) (let ((var (car varval)) (val (cadr varval))) (if val (setenv var val) (begin (debug:print-error 0 *default-log-port* "required variable " var " does not have a valid value. Exiting") (exit))))) (list (list "MT_TEST_RUN_DIR" work-area) (list "MT_TEST_NAME" test-name) (list "MT_ITEM_INFO" (conc itemdat)) (list "MT_ITEMPATH" item-path) (list "MT_RUNNAME" runname) (list "MT_MEGATEST" megatest) (list "MT_TARGET" target) (list "MT_LINKTREE" (common:get-linktree)) (list "MT_TESTSUITENAME" (common:get-testsuite-name)))) (let ((tmppath (getenv "PATH"))) (if (string-search tmppath " ") (debug:print 0 *default-log-port* "WARNING: spaces in PATH are not supported.")) (if mt-bindir-path (setenv "PATH" (conc tmppath":"mt-bindir-path)))) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) (set-item-env-vars itemdat) (let ((blacklist (configf:lookup *configdat* "setup" "blacklistvars"))) (if blacklist (let ((vars (string-split blacklist))) (save-environment-as-files "megatest" ignorevars: vars) (for-each (lambda (var) (unsetenv var)) vars)) (save-environment-as-files "megatest"))) (tests:set-full-meta-info #f test-id run-id 0 work-area 10) (if (args:get-arg "-xterm") (set! fullrunscript "xterm") (if (and fullrunscript (common:file-exists? fullrunscript) (not (file-execute-access? fullrunscript))) (system (conc "chmod ug+x " fullrunscript)))) (launch:extract-scripts-logpro work-area test-name item-path tconfigreg) (let* ((m (make-mutex)) (kill-job? #f) (exit-info (make-launch:einf pid: #t exit-status: #t exit-code: #t rollup-status: 0)) ;; pid exit-status exit-code (i.e. process was successfully run) rollup-status (job-thread #f) ;; (keep-going #t) (misc-flags (let ((ht (make-hash-table))) (hash-table-set! ht 'keep-going #t) ht)) (runit (lambda () (launch:manage-steps run-id test-id item-path fullrunscript ezsteps subrun test-name tconfigreg exit-info m))) (monitorjob (lambda () (launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags))) (th1 (make-thread monitorjob "monitor job")) (th2 (make-thread runit "run job")) (tconfig (tests:get-testconfig test-name item-path tconfigreg #t)) (propagate-exit-code (configf:lookup *configdat* "setup" "propagate-exit-code")) (propagate-status-list '("FAIL" "KILLED" "ABORT" "DEAD" "CHECK" "SKIP" "WAIVED")) (test-status "not set") (test-state "not set") (precmd (configf:lookup tconfig "setup" "precmd")) (postcmd (configf:lookup tconfig "setup" "postcmd"))) ;; first, if set, run the precmd (if precmd ;; (file-exists? precmd)(file-execute-access? precmd)) (begin ;; (save-environment-as-files "precmd-envt") (system precmd))) ;; up to test author to put nbfake if desired. (set! job-thread th2) (thread-start! th1) (thread-start! th2) (thread-join! th2) (debug:print-info 0 *default-log-port* "Megatest execute of test " test-name ", item path " item-path " complete. Notifying the db ...") (debug:print-info 2 *default-log-port* "exit-info = " exit-info) (hash-table-set! misc-flags 'keep-going #f) (thread-join! th1) (thread-sleep! 1) ;; give thread th1 a chance to be done TODO: Verify this is needed. At 0.1 I was getting fail to stop, increased to total of 1.1 sec. (mutex-lock! m) (let* ((item-path (item-list->path itemdat)) ;; REMOVE this call and change this section to get killrequest from disk file ;; FUTURE: the test will start a tcp server to listen for kill requests ;; only state and status needed - use lazy routine (testinfo (rmt:get-testinfo-state-status run-id test-id))) ;; Am I completed? (if (member (db:test-get-state testinfo) '("REMOTEHOSTSTART" "RUNNING")) (let ((new-state (if kill-job? "KILLED" "COMPLETED")) (new-status (cond ((not (launch:einf-exit-status exit-info)) "FAIL") ;; job failed to run ... (vector-ref exit-info 1) ((eq? (launch:einf-rollup-status exit-info) 0) ;; (vector-ref exit-info 3) ;; if the current status is AUTO then defer to the calculated value (i.e. leave this AUTO) (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO" "PASS")) ((eq? (launch:einf-rollup-status exit-info) 1) "FAIL") ;; (vector-ref exit-info 3) ((eq? (launch:einf-rollup-status exit-info) 2) ;; (vector-ref exit-info 3) ;; if the current status is AUTO the defer to the calculated value but ;; qualify (i.e. make this AUTO-WARN) (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN")) ((eq? (launch:einf-rollup-status exit-info) 3) "CHECK") ((eq? (launch:einf-rollup-status exit-info) 4) "WAIVED") ((eq? (launch:einf-rollup-status exit-info) 5) "ABORT") ((eq? (launch:einf-rollup-status exit-info) 6) "SKIP") (else "FAIL")))) (debug:print-info 0 *default-log-port* "Test exited in state=" (db:test-get-state testinfo) ", setting state/status based on exit code of " (launch:einf-exit-status exit-info) " and rollup-status of " (launch:einf-rollup-status exit-info)) ;; Leave a .final-status file for each sub-test (tests:save-final-status run-id test-id) (tests:test-set-status! run-id test-id new-state new-status (args:get-arg "-m") #f))) ;; for automated creation of the rollup html file this is a good place... (if (not (equal? item-path "")) (tests:summarize-items run-id test-id test-name #f)) ;; BUG was this meant to be the antecedent of the if above? (tests:summarize-test run-id test-id) ;; don't force - just update if no ;; Leave a .final-status file for the top level test (tests:save-final-status run-id test-id) ;; WHAT IS THIS FOR? TWO CALLS BACK TO SERVER? (rmt:update-run-stats run-id 'run)) ;; (rmt:get-raw-run-stats run-id))) ;; end of let* (mutex-unlock! m) (launch:end-of-run-check run-id ) (debug:print 2 *default-log-port* "Output from running " fullrunscript ", pid " (launch:einf-pid exit-info) " in work area " work-area ":\n====\n exit code " (launch:einf-exit-code exit-info) "\n" "====\n") (let* ((testrec (rmt:get-testinfo-state-status run-id test-id))) (set! test-status (db:test-get-status testrec)) (set! test-state (db:test-get-state testrec))) ;; If the propagate-exit-code option has been set in the megatest config ;; and the test status matches the list, set the exit code to 1. (if (and propagate-exit-code (string=? propagate-exit-code "yes") (member test-status propagate-status-list)) (begin (debug:print 1 *default-log-port* "Setting exit status to 1 because of test status of " test-status) (set! *globalexitstatus* 1))) (if postcmd (begin (setenv "MT_TEST_STATE" test-state) (setenv "MT_TEST_STATUS" test-status) ;; (save-environment-as-files "postcmd-envt") (system postcmd))) (if (not (launch:einf-exit-status exit-info)) (exit 4)))) ))) ;; Spec for End of test ;; At end of each test call, after marking self as COMPLETED do run-state-status-rollup ;; At transition to run COMPLETED/X do hooks ;; Definition: test_dead if event_time + duration + 1 minute? < current_time AND ;; we can prove the process is not alive (ssh host pstree -A pid) ;; if dead safe to mark the test as killed in the db ;; State/status table ;; 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 *last-rollup* 0) (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)) (all-test-launched (rmt:get-var (conc "lunch-complete-" run-id))) (current-state-status (rmt:get-run-state-status run-id)) (current-state (car current-state-status)) ;; (rmt:get-run-state run-id)) (current-status (cdr current-state-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) ;; ;; TODO: add a final rollup when run is done (if there isn't one already) ;; (if (or (< running-cnt 3) ;; have only few running (> (- (current-seconds) *last-rollup*) 10)) ;; or haven't rolled up in past ten seconds (begin (rmt:set-state-status-and-roll-up-run run-id current-state current-status) (set! *last-rollup* (current-seconds)))) (runs:update-junit-test-reporter-xml run-id) (cond ((and all-test-launched (eq? not-completed-cnt 0) (equal? all-test-launched "yes" )) (if (and (equal? (rmt:get-var (conc "end-of-run-" run-id)) "no") (common:simple-lock (conc "endOfRun" run-id))) (begin (debug:print 4 *default-log-port* "look for post hook. currseconds: " (current-seconds) " EOR " (rmt:get-var (conc "end-of-run-" run-id))) (debug:print 0 *default-log-port* "End of Run Detected.") |
︙ | ︙ | |||
771 772 773 774 775 776 777 | (if (> (length not-completed-tests) 0) (let loop ((running-test (car not-completed-tests)) (tal (cdr not-completed-tests))) (let* ((test-name (vector-ref running-test 2)) (item-path (vector-ref running-test 11))) (debug:print 0 *default-log-port* "test " test-name "/" item-path " not completed") (if (not (null? tal)) | | | < < < < < < < < < < < < | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < < < < < < < < < < < < < < < | | 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 | (if (> (length not-completed-tests) 0) (let loop ((running-test (car not-completed-tests)) (tal (cdr not-completed-tests))) (let* ((test-name (vector-ref running-test 2)) (item-path (vector-ref running-test 11))) (debug:print 0 *default-log-port* "test " test-name "/" item-path " not completed") (if (not (null? tal)) (loop (car tal) (cdr tal))))))))))) (define (launch:kill-tests-if-dead run-id) (let* ((running-tests (rmt:get-tests-for-run run-id "%" `("RUNNING" "LAUNCHED" "REMOTEHOSTSTART") `() #f #f #f #f #f #f #f #f))) (let loop ((running-test (car running-tests)) (tal (cdr running-tests)) (kill-cnt 0)) (let* ((test-name (vector-ref running-test 2)) (item-path (vector-ref running-test 11)) (test-id (vector-ref running-test 0)) (host (vector-ref running-test 6)) (pid (rmt:test-get-top-process-pid run-id test-id)) (event-time (vector-ref running-test 5)) (duration (vector-ref running-test 12)) (flag 0) (curr-time (current-seconds))) (if (and (< (+ event-time duration 600) curr-time) (not (commonmod:is-test-alive host pid))) ;;test has not updated duration in last 10 min then likely its not running but confirm before marking it as killed (begin (debug:print 0 *default-log-port* "test " test-name "/" item-path " needs to be killed") (set! flag 1) (rmt:set-state-status-and-roll-up-items run-id test-name item-path "KILLREQ" "n/a" #f))) (if (not (null? tal)) (loop (car tal) (cdr tal) (+ kill-cnt flag)) (+ kill-cnt flag)))))) ;; DO NOT USE - caching of configs is handled in launch:setup now. ;; (define (launch:cache-config) ;; if we have a linktree and -runtests and -target and the directory exists dump the config ;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg (if (and *configdat* (or (args:get-arg "-run") (args:get-arg "-runtests") (args:get-arg "-execute"))) (let* ((linktree (common:get-linktree)) ;; (get-environment-variable "MT_LINKTREE")) (target (common:args-get-target exit-if-bad: #t)) (runname (or (args:get-arg "-runname") (args:get-arg ":runname") (getenv "MT_RUNNAME"))) (fulldir (conc linktree "/" target "/" runname))) (if (and linktree (common:file-exists? linktree)) ;; can't proceed without linktree (begin (debug:print-info 0 *default-log-port* "Have -run with target=" target ", runname=" runname ", fulldir=" fulldir ", testpatt=" (or (args:get-arg "-testpatt") "%")) (if (not (common:file-exists? fulldir)) (create-directory fulldir #t)) ;; need to protect with exception handler (if (and target runname (common:file-exists? fulldir)) (let ((tmpfile (conc fulldir "/.megatest.cfg." (current-seconds))) (targfile (conc fulldir "/.megatest.cfg-" megatest-version "-" megatest-fossil-hash)) (rconfig (conc fulldir "/.runconfig." megatest-version "-" megatest-fossil-hash))) (if (common:file-exists? rconfig) ;; only cache megatest.config AFTER runconfigs has been cached (begin (debug:print-info 2 *default-log-port* "Caching megatest.config in " tmpfile) (if (not (common:in-running-test?)) (configf:write-alist *configdat* tmpfile)) (system (conc "ln -sf " tmpfile " " targfile)))) ))) (debug:print-info 1 *default-log-port* "No linktree yet, no caching configs."))))) ;; gather available information, if legit read configs in this order: ;; ;; if have cache; ;; read it a return it ;; else ;; megatest.config (do not cache) ;; runconfigs.config (cache if all vars avail) ;; megatest.config (cache if all vars avail) ;; returns: ;; *toppath* ;; side effects: ;; sets; *configdat* (megatest.config info) ;; *runconfigdat* (runconfigs.config info) ;; *configstatus* (status of the read data) ;; (define (launch:setup #!key (force-reread #f) (areapath #f)) (mutex-lock! *launch-setup-mutex*) ;; this stops the train quickly for new processes (if (and *toppath* (file-exists? (conc *toppath*"/stop-the-train"))) (begin (debug:print 0 *default-log-port* "ERROR: found file "*toppath*"/stop-the-train, exiting immediately") (exit 1))) (if (and *toppath* (eq? *configstatus* 'fulldata) (not force-reread)) ;; got it all (begin (debug:print 2 *default-log-port* "NOTE: skipping launch:setup-body call since we have fulldata") (mutex-unlock! *launch-setup-mutex*) *toppath*) (let ((res (launch:setup-body force-reread: force-reread areapath: areapath))) (mutex-unlock! *launch-setup-mutex*) res))) ;; return paths depending on what info is available. ;; (define (launch:get-cache-file-paths areapath toppath target mtconfig) (let* ((use-cache (common:use-cache?)) (runname (common:args-get-runname)) (linktree (common:get-linktree)) (testname (common:get-full-test-name)) (rundir (if (and runname target linktree) (common:directory-writable? (conc linktree "/" target "/" runname)) #f)) |
︙ | ︙ | |||
892 893 894 895 896 897 898 | (not force-reread)) ;; no need to reprocess *toppath* ;; return toppath (let* ((use-cache (common:use-cache?)) ;; BB- use-cache checks *configdat* for use-cache setting. We do not have *configdat*. Bootstrapping problem here. (toppath (common:get-toppath areapath)) (target (common:args-get-target)) (sections (if target (list "default" target) #f)) ;; for runconfigs (mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config | | | 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 | (not force-reread)) ;; no need to reprocess *toppath* ;; return toppath (let* ((use-cache (common:use-cache?)) ;; BB- use-cache checks *configdat* for use-cache setting. We do not have *configdat*. Bootstrapping problem here. (toppath (common:get-toppath areapath)) (target (common:args-get-target)) (sections (if target (list "default" target) #f)) ;; for runconfigs (mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config (cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig)) ;; checking for null cachefiles should not be necessary, I was seeing error car of '(), might be a chicken bug or a red herring ... (mtcachef (if (null? cachefiles) #f (car cachefiles))) ;; (and cachedir (conc cachedir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash))) (rccachef (if (null? cachefiles) #f (cdr cachefiles)))) ;; (and cachedir (conc cachedir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash))) |
︙ | ︙ | |||
973 974 975 976 977 978 979 | pathenvvar: "MT_RUN_AREA_HOME")) (runconfigdat (begin ;; this read of the runconfigs will see any adjustments made by re-reading megatest.config (for-each (lambda (kt) (setenv (car kt) (cadr kt))) key-vals) (read-config (conc toppath "/runconfigs.config") *runconfigdat* #t ;; consider using runconfig:read some day ... sections: sections))) | | | 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 | pathenvvar: "MT_RUN_AREA_HOME")) (runconfigdat (begin ;; this read of the runconfigs will see any adjustments made by re-reading megatest.config (for-each (lambda (kt) (setenv (car kt) (cadr kt))) key-vals) (read-config (conc toppath "/runconfigs.config") *runconfigdat* #t ;; consider using runconfig:read some day ... sections: sections))) (cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig)) (mtcachef (car cachefiles)) (rccachef (cdr cachefiles))) ;; trap exception due to stale NFS handle -- Error: (open-output-file) cannot open file - Stale NFS file handle: "/p/fdk/gwa/lefkowit/mtTesting/qa/primbeqa/links/p1222/11/PDK_r1.1.1/prim/clean/pcell_testgen/.runconfigs.cfg-1.6427-7d1e789cb3f62f9cde719a4865bb51b3c17ea853" - ticket 220546342 ;; TODO - consider 1) using simple-lock to bracket cache write ;; 2) cache in hash on server, since need to do rmt: anyway to lock. (if rccachef |
︙ | ︙ | |||
1054 1055 1056 1057 1058 1059 1060 | (begin (setenv "MT_RUN_AREA_HOME" *toppath*) (setenv "MT_TESTSUITENAME" (common:get-testsuite-name))) (begin (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.") (set! *toppath* #f) ;; force it to be false so we return #f #f)) | | > > > | | 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 | (begin (setenv "MT_RUN_AREA_HOME" *toppath*) (setenv "MT_TESTSUITENAME" (common:get-testsuite-name))) (begin (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.") (set! *toppath* #f) ;; force it to be false so we return #f #f)) ;; needed by various transport and db modules (dbfile:testsuite-name (common:get-testsuite-name)) ;; (get-testsuite-name *toppath* *configdat*)) ;; one more attempt to cache the configs for future reading (let* ((cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig)) (mtcachef (car cachefiles)) (rccachef (cdr cachefiles))) ;; trap exception due to stale NFS handle -- Error: (open-output-file) cannot open file - Stale NFS file handle: "...somepath.../.runconfigs.cfg-1.6427-7d1e789cb3f62f9cde719a4865bb51b3c17ea853" - ticket 220546342 ;; TODO - consider 1) using simple-lock to bracket cache write ;; 2) cache in hash on server, since need to do rmt: anyway to lock. (if (and rccachef *runconfigdat* (not (common:file-exists? rccachef))) |
︙ | ︙ | |||
1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 | (set! *configstatus* 'fulldata))) ;; if have -append-config then read and append here (let ((cfname (args:get-arg "-append-config"))) (if (and cfname (file-read-access? cfname)) (read-config cfname *configdat* #t))) ;; values are added to the hash, no need to do anything special. *toppath*))) (define (get-best-disk confdat testconfig) (let* ((disks (or (and testconfig (hash-table-ref/default testconfig "disks" #f)) (hash-table-ref/default confdat "disks" #f))) (minspace (let ((m (configf:lookup confdat "setup" "minspace"))) (string->number (or m "10000"))))) (if disks | > > > > > > > > > > > > > > > > > > > | > | | < < | > > > > | > | > > > > > | > > | 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 | (set! *configstatus* 'fulldata))) ;; if have -append-config then read and append here (let ((cfname (args:get-arg "-append-config"))) (if (and cfname (file-read-access? cfname)) (read-config cfname *configdat* #t))) ;; values are added to the hash, no need to do anything special. ;; have config at this time, this is a good place to set params based on config file settings (let* ((dbmode (configf:lookup *configdat* "setup" "dbcache-mode")) (syncmode (configf:lookup *configdat* "setup" "sync-mode")) (srvdebug (configf:lookup *configdat* "server" "debug-parameter"))) (if dbmode (begin (debug:print-info 0 *default-log-port* "Overriding dbmode to "dbmode) (dbcache-mode (string->symbol dbmode)))) (if syncmode (begin (debug:print-info 0 *default-log-port* "Overriding syncmode to "syncmode) (dbfile:sync-method (string->symbol syncmode)))) (if srvdebug (begin (debug:print-info 0 *default-log-port* "Overriding server debug parameter to "srvdebug) (tt-server-profile-string srvdebug))) ) *toppath*))) (define (get-best-disk confdat testconfig) (let* ((disks (or (and testconfig (hash-table-ref/default testconfig "disks" #f)) (hash-table-ref/default confdat "disks" #f))) (minspace (let ((m (configf:lookup confdat "setup" "minspace"))) (string->number (or m "10000"))))) (if disks (let ((res (common:get-disk-with-most-free-space disks minspace))) (if res (cdr res) ;; else if no valid disks... (begin (debug:print 0 *default-log-port* "WARNING: No valid disks or no disk with enough space found from " disks) (if (null? disks) (cons 1 (conc *toppath* "/runs")) ;; else try to create the directories anyway. (let ((paths (sort disks (lambda (x y) (> (string-length (cadr x)) (string-length (cadr y))))))) (let loop ((head (car paths)) (tail (cdr paths))) (let ((result (handle-exceptions exn (begin (debug:print 0 *default-log-port* "failed to create dir " (cadr head) ", exn=" exn) #f) (create-directory (cadr head) #t)))) (if result result (if (null? tail) (begin (debug:print 0 *default-log-port* "Using toppath/runs") (conc *toppath* "/runs") ) (loop (car tail) (cdr tail)))))) ) ) ;; if null? disks ) ;; if not res ) ) ;; no disks definition - use toppath/runs, fall back to currdir/runs (let* ((toppath (or *toppath* (common:get-toppath *toppath*) (begin (debug:print-error 0 *default-log-port* "Creating runs dir in current directory, this is probably not what you wanted. Please check your setup.") (current-directory)))) (runsdir (conc toppath "/runs"))) (if (not (file-exists? runsdir))(create-directory runsdir)) runsdir) ))) ;; the code creates the necessary directories if it does not exist and returns the path. (define (launch:test-copy test-src-path test-path) (let* ((ovrcmd (let ((cmd (configf:lookup *configdat* "setup" "testcopycmd"))) (if cmd ;; substitute the TEST_SRC_PATH and TEST_TARG_PATH (string-substitute "TEST_TARG_PATH" test-path (string-substitute "TEST_SRC_PATH" test-src-path cmd #t) #t) |
︙ | ︙ | |||
1278 1279 1280 1281 1282 1283 1284 | ;; (rmt:general-call 'test-set-rundir run-id lnkpath testname "") ;; toptest-path) (if (or (not curr-test-path) (not (directory-exists? toptest-path))) (begin (debug:print-info 2 *default-log-port* "Creating " toptest-path " and link " lnkpath) (handle-exceptions exn | > > | | | > > | | | | | 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 | ;; (rmt:general-call 'test-set-rundir run-id lnkpath testname "") ;; toptest-path) (if (or (not curr-test-path) (not (directory-exists? toptest-path))) (begin (debug:print-info 2 *default-log-port* "Creating " toptest-path " and link " lnkpath) (handle-exceptions exn (if (directory-exists? toptest-path) ;; it was likely created in parallel #t (begin (debug:print-info 0 *default-log-port* "failed to create directory " toptest-path ", exn=" exn) #f)) (create-directory toptest-path #t)) (hash-table-set! *toptest-paths* testname toptest-path))))) ;; The toptest path has been created, the link to the test in the linktree has ;; been created. Now, if this is an iterated test the real test dir must be created (if (not not-iterated) ;; this is an iterated test (begin ;; (let ((lnktarget (conc lnkpath "/" item-path))) (debug:print 2 *default-log-port* "Setting up sub test run area") (debug:print 2 *default-log-port* " - creating run area in " test-path) (handle-exceptions exn (if (directory-exists? test-path) #t (begin (debug:print-error 0 *default-log-port* " Failed to create directory " test-path ((condition-property-accessor 'exn 'message) exn) ", exiting, exn=" exn) (exit 1))) (create-directory test-path #t)) (debug:print 2 *default-log-port* " - creating link from: " test-path "\n" " to: " lnktarget) ;; If there is already a symlink delete it and recreate it. (handle-exceptions |
︙ | ︙ | |||
1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 | ;; 2. create run dir on disk, path name is meaningful ;; 3. create link from run dir to megatest runs area ;; 4. remotely run the test on allocated host ;; - could be ssh to host from hosts table (update regularly with load) ;; - could be netbatch ;; (launch-test db (cadr status) test-conf)) (define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params) (mutex-lock! *launch-setup-mutex*) ;; setting variables and processing the testconfig is NOT thread-safe, reuse the launch-setup mutex (let* (;; locking code removed from here commented out and pasted at end of file (item-path (item-list->path itemdat)) (contour #f) ;; NOT READY FOR THIS (args:get-arg "-contour"))) ;; launcher-mode will be 'adjutant or 'normal (launcher-mode (string->symbol (or (configf:lookup *configdat* "jobtools" "mode") "normal"))) (ajtdat (make-launch:ajt))) (let loop ((delta (- (current-seconds) *last-launch*)) (launch-delay (configf:lookup-number *configdat* "setup" "launch-delay" default: 0))) (if (> launch-delay delta) (begin | > | | | 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 | ;; 2. create run dir on disk, path name is meaningful ;; 3. create link from run dir to megatest runs area ;; 4. remotely run the test on allocated host ;; - could be ssh to host from hosts table (update regularly with load) ;; - could be netbatch ;; (launch-test db (cadr status) test-conf)) (define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params) (assert runname "FATAL: launch-test called with no runname") (mutex-lock! *launch-setup-mutex*) ;; setting variables and processing the testconfig is NOT thread-safe, reuse the launch-setup mutex (let* (;; locking code removed from here commented out and pasted at end of file (item-path (item-list->path itemdat)) (contour #f) ;; NOT READY FOR THIS (args:get-arg "-contour"))) ;; launcher-mode will be 'adjutant or 'normal (launcher-mode (string->symbol (or (configf:lookup *configdat* "jobtools" "mode") "normal"))) (ajtdat (make-launch:ajt))) (let loop ((delta (- (current-seconds) *last-launch*)) (launch-delay (configf:lookup-number *configdat* "setup" "launch-delay" default: 0))) (if (> launch-delay delta) (begin ;; (if (common:low-noise-print 1200 "test launch delay") ;; every two hours or so remind the user about launch delay. ;; (debug:print-info 0 *default-log-port* "NOTE: test launches are delayed by " launch-delay " seconds. See megatest.config launch-delay setting to adjust.")) ;; launch of " test-name " for " (- launch-delay delta) " seconds")) (thread-sleep! (- launch-delay delta)) (loop (- (current-seconds) *last-launch*) launch-delay)))) (change-directory *toppath*) (let ((var-list (append (list (list "MT_RUN_AREA_HOME" *toppath*) (list "MT_TEST_NAME" test-name) |
︙ | ︙ | |||
1463 1464 1465 1466 1467 1468 1469 1470 | ;; prevent overlapping actions - set to LAUNCHED as early as possible ;; ;; the following call handles waiver propogation. cannot yet condense into roll-up-pass-fail (tests:test-set-status! run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED")) (rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "LAUNCHED" #f) ;; (pp (hash-table->alist tconfig)) (set! diskpath (get-best-disk *configdat* tconfig)) (if diskpath | > | | | | 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 | ;; prevent overlapping actions - set to LAUNCHED as early as possible ;; ;; the following call handles waiver propogation. cannot yet condense into roll-up-pass-fail (tests:test-set-status! run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED")) (rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "LAUNCHED" #f) ;; (pp (hash-table->alist tconfig)) (set! diskpath (get-best-disk *configdat* tconfig)) (debug:print 2 *default-log-port* "best disk path = " diskpath) (if diskpath (let ((dat (create-work-area run-id run-info keyvals test-id test-path diskpath test-name itemdat))) (set! work-area (car dat)) (set! toptest-work-area (cadr dat)) (debug:print-info 2 *default-log-port* "Using work area " work-area)) (begin (set! work-area (conc test-path "/tmp_run")) (create-directory work-area #t) (debug:print 0 *default-log-port* "WARNING: No disk work area specified - running in the test directory under tmp_run"))) (set! cmdparms (base64:base64-encode (z3:encode-buffer (with-output-to-string (lambda () ;; (list 'hosts hosts) (write (list (list 'testpath test-path) ;; (list 'transport (conc *transport-type*)) ;; (list 'serverinf *server-info*) #;(list 'homehost (let* ((hhdat (server:get-homehost))) (if hhdat (car hhdat) #f))) #;(list 'serverurl (if *runremote* ;; would like to add this back ... WORK NEEDED (remote-server-url *runremote*) #f)) ;; (list 'areaname (common:get-testsuite-name)) (list 'toppath *toppath*) (list 'work-area work-area) (list 'test-name test-name) (list 'runscript runscript) |
︙ | ︙ | |||
1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 | (list 'runtlim (if run-time-limit (common:hms-string->seconds run-time-limit) #f)) (list 'env-ovrd (hash-table-ref/default *configdat* "env-override" '())) (list 'set-vars (if params (hash-table-ref/default params "-setvars" #f))) (list 'runname runname) (list 'mt-bindir-path mt-bindir-path)))))))) ;; save the cmdparms in the ajtdat (launch:ajt-exekey-set! ajtdat cmdparms) ;; clean out step records from previous run if they exist ;; (rmt:delete-test-step-records run-id test-id) ;; if the dir does not exist we may have a itempath where individual variables are a path, launch anyway (if (common:file-exists? work-area) (change-directory work-area)) ;; so that log files from the launch process don't clutter the test dir | > > | 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 | (list 'runtlim (if run-time-limit (common:hms-string->seconds run-time-limit) #f)) (list 'env-ovrd (hash-table-ref/default *configdat* "env-override" '())) (list 'set-vars (if params (hash-table-ref/default params "-setvars" #f))) (list 'runname runname) (list 'mt-bindir-path mt-bindir-path)))))))) ;; save the cmdparms in the ajtdat (launch:ajt-exekey-set! ajtdat cmdparms) (setenv "MT_CMDINFO" cmdparms) ;; setting this for use in nblauncher ;; clean out step records from previous run if they exist ;; (rmt:delete-test-step-records run-id test-id) ;; if the dir does not exist we may have a itempath where individual variables are a path, launch anyway (if (common:file-exists? work-area) (change-directory work-area)) ;; so that log files from the launch process don't clutter the test dir |
︙ | ︙ | |||
1601 1602 1603 1604 1605 1606 1607 | (apply print launch-results) (print "NOTE: launched \"" fullcmd "\"\n but did not wait for it to proceed. Add the following to megatest.config \n[setup]\nlaunchwait yes\n if you have problems with this")) #:append)) (debug:print 2 *default-log-port* "Launching completed, updating db") (debug:print 2 *default-log-port* "Launch results: " launch-results) (if (not launch-results) (begin | | | 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 | (apply print launch-results) (print "NOTE: launched \"" fullcmd "\"\n but did not wait for it to proceed. Add the following to megatest.config \n[setup]\nlaunchwait yes\n if you have problems with this")) #:append)) (debug:print 2 *default-log-port* "Launching completed, updating db") (debug:print 2 *default-log-port* "Launch results: " launch-results) (if (not launch-results) (begin (debug:print 0 *default-log-port* "ERROR: Failed to run " (string-intersperse fullcmd " ") ", exiting now") ;; (sqlite3:finalize! db) ;; good ole "exit" seems not to work ;; (_exit 9) ;; but this hack will work! Thanks go to Alan Post of the Chicken email list ;; NB// Is this still needed? Should be safe to go back to "exit" now? (process-signal (current-process-id) signal/kill) )) |
︙ | ︙ | |||
1646 1647 1648 1649 1650 1651 1652 | #f))) ;; now wait on that process if all is correct ;; periodically update the db with runtime ;; when the process exits look at the db, if still RUNNING after 10 seconds set ;; state/status appropriately (process-wait pid))) | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 | #f))) ;; now wait on that process if all is correct ;; periodically update the db with runtime ;; when the process exits look at the db, if still RUNNING after 10 seconds set ;; state/status appropriately (process-wait pid))) ;; (lock-key (conc "test-" test-id)) ;; (got-lock (let loop ((lock (rmt:no-sync-get-lock lock-key)) ;; (expire-time (+ (current-seconds) 15))) ;; give up on getting the lock and steal it after 15 seconds ;; (if (car lock) ;; #t ;; (if (> (current-seconds) expire-time) ;; (begin ;; (debug:print-info 0 *default-log-port* "Timed out waiting for a lock to launch test " keyvals " " runname " " test-name " " test-path) ;; (rmt:no-sync-del! lock-key) ;; destroy the lock ;; (loop (rmt:no-sync-get-lock lock-key) expire-time)) ;; ;; (begin ;; (thread-sleep! 1) ;; (loop (rmt:no-sync-get-lock lock-key) expire-time)))))) |
Added matt/buttontest.scm version [4c1acbf3a4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (use iup srfi-4) (module buttontest * (import iup) (import scheme srfi-4 (prefix iup iup:)) (define (make-image name tcolor bgcolor) (let* ((img-bits1 (u8vector->blob (u8vector 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 2 3 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 2 2 3 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 2 2 2 3 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 2 2 2 3 3 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 2 2 2 3 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 2 2 3 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 2 3 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ))) ;; w h (img1 (iup:image/palette 22 24 img-bits1))) (iup:handle-name-set! img1 name) (iup:attribute-set! img1 "1" "10 10 10") (iup:attribute-set! img1 "2" bgcolor) ;; "BGCOLOR") (iup:attribute-set! img1 "3" tcolor) name)) (iup:show (iup:dialog (iup:vbox (iup:button " " image: (make-image "GreenBlack" "0 255 0" "0 0 0"))))) (iup:main-loop) ) |
Modified megatest-version.scm from [b4d2006c23] to [4d2201c206].
︙ | ︙ | |||
16 17 18 19 20 21 22 | ;; 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)) | | | 16 17 18 19 20 21 22 23 | ;; 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.8104) |
Modified megatest.scm from [d7149ec694] to [d9a4834019].
︙ | ︙ | |||
20 21 22 23 24 25 26 | (include "megatest-version.scm") ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) (declare (uses common)) ;; (declare (uses megatest-version)) | | > > > > > > > < > > | > > > > > > > > > > > > > > > > > > > > > > > > | | | > > > > > > > > > > > > > < < | > > > > > > > > > > > > > > > > > | > > > < | | | | | | | | | | | | 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 | (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 mtargs)) (declare (uses mtargs.import)) (declare (uses debugprint)) (declare (uses debugprint.import)) (declare (uses commonmod)) (declare (uses commonmod.import)) (declare (uses runs)) (declare (uses launch)) (declare (uses server)) (declare (uses tests)) (declare (uses genexample)) ;; (declare (uses daemon)) (declare (uses db)) ;; (declare (uses dcommon)) (declare (uses tdb)) (declare (uses mt)) (declare (uses api)) (declare (uses tasks)) ;; only used for debugging. (declare (uses env)) (declare (uses diff-report)) (declare (uses db)) (declare (uses dbfile)) (declare (uses dbfile.import)) (declare (uses dbmod)) (declare (uses dbmod.import)) (declare (uses portlogger)) (declare (uses portlogger.import)) (declare (uses adjutant)) (import adjutant) (declare (uses mttop)) (import mttop) (declare (uses tcp-transportmod)) (declare (uses tcp-transportmod.import)) (declare (uses rmtmod)) (declare (uses rmtmod.import)) ;; (declare (uses debugprint)) ;; (declare (uses debugprint.import)) ;; (declare (uses ftail)) ;; (import ftail) (import (prefix mtargs args:) debugprint dbmod commonmod dbfile portlogger tcp-transportmod rmtmod ) (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:)) (use apropos call-with-environment-variables directory-utils extras format http-client json matchable readline srfi-18 tcp tcp-server typed-records ) ;; Added for csv stuff - will be removed ;; (use sparse-vectors) (require-library mutils) (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 ;; set some parameters here - these need to be put in something that can be loaded from other ;; executables such as dashboard and mtutil ;; (include "transport-mode.scm") (dbfile:db-init-proc db:initialize-main-db) (debug:enable-timestamp #t) (set! rmtmod:send-receive rmt:send-receive) ;;(lambda params (apply rmt:send-receive params))) ;; make send-receive available to rmtmod via parameter ;; 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) (begin ;; for some reason, debug:print does not work here. Had to use print. (with-output-to-port (current-error-port) (lambda () (print (conc "WARNING: loading " debugcontrolf)))) (load debugcontrolf) ) ) ) ;; usage logging, careful with this, it is not designed to deal with all real world challenges! ;; (if (and *usage-log-file* (file-write-access? *usage-log-file*)) (with-output-to-file *usage-log-file* (lambda () (print (if *usage-use-seconds* (current-seconds) (time->string (seconds->local-time (current-seconds)) "%Yww%V.%w %H:%M:%S")) " " (current-user-name) " " (current-directory) " " "\"" (string-intersperse (argv) " ") "\"")) #:append)) ;; Disabled help items ;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s) ;; from prior runs with same keys ;; -daemonize : fork into background and disconnect from stdin/out (define help (conc " Megatest, documentation at https://chiselapp.com/user/kiatoa/repository/megatest version " megatest-version " license GPL, Copyright Matt Welland 2006-2024 Usage: megatest [options] -h : this help -manual : show the Megatest user manual -version : print megatest version (currently " megatest-version ") help : help for the new Megatest interface |
︙ | ︙ | |||
221 222 223 224 225 226 227 | -load file.scm : load and run file.scm -mark-incompletes : find and mark incomplete tests -ping run-id|host:port : ping server, exit with 0 if found -debug N|N,M,O... : enable debug 0-N or N and M and O ... -debug-noprop N|M,M,O...: enable debug but do not propagate to subprocesses via MT_DEBUG -config fname : override the megatest.config file with fname -append-config fname : append fname to the megatest.config file | > > | | 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 | -load file.scm : load and run file.scm -mark-incompletes : find and mark incomplete tests -ping run-id|host:port : ping server, exit with 0 if found -debug N|N,M,O... : enable debug 0-N or N and M and O ... -debug-noprop N|M,M,O...: enable debug but do not propagate to subprocesses via MT_DEBUG -config fname : override the megatest.config file with fname -append-config fname : append fname to the megatest.config file -import-sexpr fname : import a sexpr file (use -list-runs % -dumpmode sexpr to create) -regen-testfiles : regenerate scripts and logpro files from testconfig, run in test context Utilities -env2file fname : write the environment to fname.csh and fname.sh -envcap a : save current variables labeled as context 'a' in file envdat.db -envdelta a-b : output enviroment delta from context a to context b to -o fname set the output mode with -dumpmode csh, bash or ini note: ini format will use calls to use curr and minimize path -refdb2dat refdb : convert refdb to sexp or to format specified by s-dumpmode |
︙ | ︙ | |||
246 247 248 249 250 251 252 253 254 255 256 257 258 259 | -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> -syscheck : do some very basic checks; write access and space in tmp, home, runs, links and is $DISPLAY valid -list-waivers : dump waivers for specified target, runname, testpatt to stdout Diff report -diff-rep : generate diff report (must include -src-target, -src-runname, -target, -runname and either -diff-email or -diff-html) -src-target <target> -src-runname <target> -diff-email <emails> : comma separated list of email addresses to send diff report | > | 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 | -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> -syscheck : do some very basic checks; write access and space in tmp, home, runs, links and is $DISPLAY valid -list-waivers : dump waivers for specified target, runname, testpatt to stdout -db2db : sync db to db, use -from, -to for dbs, -period and -timeout for continuous sync Diff report -diff-rep : generate diff report (must include -src-target, -src-runname, -target, -runname and either -diff-email or -diff-html) -src-target <target> -src-runname <target> -diff-email <emails> : comma separated list of email addresses to send diff report |
︙ | ︙ | |||
299 300 301 302 303 304 305 | ":state" "-state" ":status" "-status" "-list-runs" "-testdata-csv" "-testpatt" | | > | 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 | ":state" "-state" ":status" "-status" "-list-runs" "-testdata-csv" "-testpatt" ;; "--modepatt" "-modepatt" "-tagexpr" "-itempatt" "-setlog" "-set-toplog" "-runstep" "-logpro" "-m" "-rerun" "-days" "-rename-run" "-from" "-to" "-dest" "-source" "-time-stamp" ;; values and messages ":category" ":variable" |
︙ | ︙ | |||
343 344 345 346 347 348 349 350 351 352 353 354 355 356 | "-extract-ods" "-pathmod" "-env2file" "-envcap" "-envdelta" "-setvars" "-set-state-status" ;; move runs stuff here "-remove-keep" "-set-run-status" "-age" ;; archive | > > > > | 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 | "-extract-ods" "-pathmod" "-env2file" "-envcap" "-envdelta" "-setvars" "-set-state-status" "-import-sexpr" "-remove-dbs" ;; to be used only with -import-sexpr to remove megatest dbs first. "-period" ;; sync period in seconds "-timeout" ;; exit sync if timeout in seconds exceeded since last change ;; move runs stuff here "-remove-keep" "-set-run-status" "-age" ;; archive |
︙ | ︙ | |||
367 368 369 370 371 372 373 374 375 376 377 378 379 380 | "-override-timeout" "-test-files" ;; -test-paths is for listing all "-load" ;; load and exectute a scheme file "-section" "-var" "-dumpmode" "-run-id" "-ping" "-refdb2dat" "-o" "-log" "-sync-log" "-since" "-fields" | > | 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 | "-override-timeout" "-test-files" ;; -test-paths is for listing all "-load" ;; load and exectute a scheme file "-section" "-var" "-dumpmode" "-run-id" "-db" "-ping" "-refdb2dat" "-o" "-log" "-sync-log" "-since" "-fields" |
︙ | ︙ | |||
428 429 430 431 432 433 434 435 436 437 438 439 440 441 | "-run-wait" ;; wait on a run to complete (i.e. no RUNNING) "-one-pass" ;; "-local" ;; run some commands using local db access "-generate-html" "-generate-html-structure" "-list-run-time" "-list-test-time" ;; misc queries "-list-disks" "-list-targets" "-list-db-targets" "-show-runconfig" "-show-config" | > | 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 | "-run-wait" ;; wait on a run to complete (i.e. no RUNNING) "-one-pass" ;; "-local" ;; run some commands using local db access "-generate-html" "-generate-html-structure" "-list-run-time" "-list-test-time" "-regen-testfiles" ;; misc queries "-list-disks" "-list-targets" "-list-db-targets" "-show-runconfig" "-show-config" |
︙ | ︙ | |||
459 460 461 462 463 464 465 466 467 468 469 470 471 472 | "-create-megatest-area" "-mark-incompletes" "-convert-to-norm" "-convert-to-old" "-import-megatest.db" "-sync-to-megatest.db" "-sync-brute-force" "-logging" "-v" ;; verbose 2, more than normal (normal is 1) "-q" ;; quiet 0, errors/warnings only "-diff-rep" | > | 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 | "-create-megatest-area" "-mark-incompletes" "-convert-to-norm" "-convert-to-old" "-import-megatest.db" "-sync-to-megatest.db" "-db2db" "-sync-brute-force" "-logging" "-v" ;; verbose 2, more than normal (normal is 1) "-q" ;; quiet 0, errors/warnings only "-diff-rep" |
︙ | ︙ | |||
502 503 504 505 506 507 508 509 510 511 512 | (exit 1)))) ;; immediately set MT_TARGET if -reqtarg or -target are available ;; (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")))) (if targ (setenv "MT_TARGET" targ))) ;; The watchdog is to keep an eye on things like db sync etc. ;; ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage | > > > > > | | | | | | | | | | > > > > > > > > > > | | < | | > | > > > | 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 | (exit 1)))) ;; immediately set MT_TARGET if -reqtarg or -target are available ;; (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")))) (if targ (setenv "MT_TARGET" targ))) ;; set the purpose field in procinf (procinf-purpose-set! *procinf* (get-purpose args:arg-hash)) (procinf-mtversion-set! *procinf* megatest-version) ;; The watchdog is to keep an eye on things like db sync etc. ;; ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage ;;(define *watchdog* (make-thread ;; (lambda () ;; (handle-exceptions ;; exn ;; (begin ;; (print-call-chain) ;; (print " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)) ;; (common:watchdog))) ;; "Watchdog thread")) ;;(if (not (args:get-arg "-server")) ;; (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog (let* ((no-watchdog-args '("-list-runs" "-testdata-csv" "-list-servers" "-server" "-adjutant" "-list-disks" "-list-targets" "-show-runconfig" ;;"-list-db-targets" "-show-runconfig" "-show-config" "-show-cmdinfo" "-cleanup-db" )) (no-watchdog-argvals (list '("-archive" . "replicate-db"))) (start-watchdog-specail-arg-val (let loop ((hed (car no-watchdog-argvals)) (tail (cdr no-watchdog-argvals))) ;; (print "hed" hed " arg " (args:get-arg (car hed)) " val:" (cdr hed) " eql" (equal? (args:get-arg (car hed)) (cdr hed))) (if (equal? (args:get-arg (car hed)) (cdr hed)) #f (if (null? tail) #t (loop (car tail) (cdr tail)))))) (no-watchdog-args-vals (filter (lambda (x) x) (map args:get-arg no-watchdog-args))) (start-watchdog (and (null? no-watchdog-args-vals) start-watchdog-specail-arg-val))) ;(print "no-watchdog-args="no-watchdog-args "no-watchdog-args-vals="no-watchdog-args-vals " start-watchdog-specail-arg-val:" start-watchdog-specail-arg-val " start-watchdog:" start-watchdog) ;; (if start-watchdog ;; (thread-start! *watchdog*)) #t ) ;; stop the train watchdog (stop-the-train) ;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions (define (open-logfile logpath-in) (condition-case (let* ((log-dir (or (pathname-directory logpath-in) ".")) (fname (pathname-strip-directory logpath-in)) (logpath (if (> (string-length fname) 250) |
︙ | ︙ | |||
563 564 565 566 567 568 569 | (define *didsomething* #t) (exit 1)))) ;; this segment will run launch:setup only if -log is not set. This is fairly safe as servers are not ;; manually started and thus should never be started in a non-megatest area. Thus no need to handle situation ;; where (launch:setup) returns #f? ;; | | | | < > | | 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 | (define *didsomething* #t) (exit 1)))) ;; this segment will run launch:setup only if -log is not set. This is fairly safe as servers are not ;; manually started and thus should never be started in a non-megatest area. Thus no need to handle situation ;; where (launch:setup) returns #f? ;; (if (or (args:get-arg "-log")#;(args:get-arg "-server")) ;; redirect the log always when a server (handle-exceptions exn (begin (print "ERROR: Failed to switch to log output. " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)) (let* ((tl (or (args:get-arg "-log")(launch:setup))) ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified (dbname (args:get-arg "-db")) ;; for the server logfile name (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name (conc tl "/logs/server-"(or dbname "unk")"-"(current-process-id) "-" (get-host-name) ".log"))) (oup (open-logfile logf))) (if (not (args:get-arg "-log")) (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log (debug:print-info 0 *default-log-port* "Sending log output to " logf) (set! *default-log-port* oup)))) (if (or (args:get-arg "-h") |
︙ | ︙ | |||
632 633 634 635 636 637 638 | (printf "Sending signal/term to ~A\n" pid) (process-signal pid signal/term)))))) (process:children #f)) (original-exit exit-code))))) ;; for some switches always print the command to stderr ;; | | < < < < < < < < < < < < < | 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 | (printf "Sending signal/term to ~A\n" pid) (process-signal pid signal/term)))))) (process:children #f)) (original-exit exit-code))))) ;; for some switches always print the command to stderr ;; (if (args:any-defined? "-run" "-runall" "-remove-runs" "-set-state-status" "-kill-runs" "-kill-rerun") (debug:print 0 *default-log-port* (string-intersperse (argv) " "))) ;;====================================================================== ;; Misc setup stuff ;;====================================================================== (debug:setup) |
︙ | ︙ | |||
699 700 701 702 703 704 705 | (if (args:get-arg "-env2file") (begin (save-environment-as-files (args:get-arg "-env2file")) (set! *didsomething* #t))) (if (args:get-arg "-list-disks") (let ((toppath (launch:setup))) | < | | | | | | | | 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 | (if (args:get-arg "-env2file") (begin (save-environment-as-files (args:get-arg "-env2file")) (set! *didsomething* #t))) (if (args:get-arg "-list-disks") (let ((toppath (launch:setup))) (print (string-intersperse (map (lambda (x) (string-intersperse x " => ")) (common:get-disks *configdat*)) "\n")) (set! *didsomething* #t))) ;; csv processing record (define (make-refdb:csv) (vector (make-sparse-array) (make-hash-table) |
︙ | ︙ | |||
865 866 867 868 869 870 871 | (if out-file (close-output-port out-port)) (exit) ;; yes, bending the rules here - need to exit since this is a utility )) (if (args:get-arg "-ping") (let* ((server-id (string->number (args:get-arg "-ping"))) ;; extract run-id (i.e. no ":" (host:port (args:get-arg "-ping"))) | > > | | < < < | 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 | (if out-file (close-output-port out-port)) (exit) ;; yes, bending the rules here - need to exit since this is a utility )) (if (args:get-arg "-ping") (let* ((server-id (string->number (args:get-arg "-ping"))) ;; extract run-id (i.e. no ":" (host:port (args:get-arg "-ping"))) (debug:print 0 *default-log-port* "NOT YET REIMPLEMENTED FOR TCP/INMEM") ;; bug (exit))) ;; (server:ping (or server-id host:port) #f do-exit: #t))) ;;====================================================================== ;; Capture, save and manipulate environments ;;====================================================================== ;; NOTE: Keep these above the section where the server or client code is setup (let ((envcap (args:get-arg "-envcap"))) (if envcap (let* ((db (env:open-db (if (null? remargs) "envdat.db" (car remargs))))) (env:save-env-vars db envcap) (env:close-database db) (set! *didsomething* #t)))) ;; delta "language" will eventually be res=a+b-c but for now it is just res=a-b ;; (let ((envdelta (args:get-arg "-envdelta"))) (if envdelta (let ((match (string-split envdelta "-")));; (string-match "([a-z0-9_]+)=([a-z0-9_\\-,]+)" envdelta))) (if (not (null? match)) (let* ((db (env:open-db (if (null? remargs) "envdat.db" (car remargs)))) ;; (resctx (cadr match)) |
︙ | ︙ | |||
919 920 921 922 923 924 925 | ;; Start the server - can be done in conjunction with -runall or -runtests (one day...) ;; we start the server if not running else start the client thread ;;====================================================================== ;; Server? Start up here. ;; (if (args:get-arg "-server") | > > | > | > | > > > > > > > > > | 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 | ;; Start the server - can be done in conjunction with -runall or -runtests (one day...) ;; we start the server if not running else start the client thread ;;====================================================================== ;; Server? Start up here. ;; (if (args:get-arg "-server") (let* (;; (run-id (args:get-arg "-run-id")) (dbfname (args:get-arg "-db")) (tl (launch:setup)) (keys (keys:config-get-fields *configdat*))) (case (rmt:transport-mode) ((tcp) (let* ((timeout (server:expiration-timeout))) (debug:print 0 *default-log-port* "INFO: megatest -server starting on " (get-host-name) " for " dbfname " using tcp method with timeout of "timeout) (tt-server-timeout-param timeout) (thread-start! (make-thread api:print-db-stats "print-db-stats")) (if dbfname (tt:start-server tl #f dbfname api:tcp-dispatch-request-make-handler keys) (begin (debug:print 0 *default-log-port* "ERROR: transport mode is tcp - -db is required.") (exit 1))))) (else (debug:print 0 *default-log-port* "ERROR: rmt:transport-mode value not recognised "(rmt:transport-mode)))) (set! *didsomething* #t))) (define (naylist->alist inlst) (map (lambda (dat) (cons (car dat) (or (if (list? (cdr dat)) |
︙ | ︙ | |||
963 964 965 966 967 968 969 | (else (thread-sleep! 10) (loop (+ wait-count 1))))) (print "I'm bored. Exiting."))) ;; (adjutant-run (args:get-arg "-ajutant") rmt:no-sync-take-job) (set! *didsomething* #t))) | | < | < | > | > > > | | > > > > > | | > > > > > | > > > > > | | > > > | | < > | > > | > > > | > > > | > > > > > | | | | | | | | > > > > > > > | > > > > > > | > > > > > | > > > > | > > > > > > > > > | > > > > > > > > > > > > > | | < < > > | 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 | (else (thread-sleep! 10) (loop (+ wait-count 1))))) (print "I'm bored. Exiting."))) ;; (adjutant-run (args:get-arg "-ajutant") rmt:no-sync-take-job) (set! *didsomething* #t))) (if (args:get-arg "-list-servers") (let* ((tl (launch:setup)) ;; need this to initialize *toppath* (servdir (tt:get-servinfo-dir *toppath*)) (servfiles (glob (conc servdir "/*:*.db"))) (fmtstr "~10a~22a~10a~25a~25a~8a\n") (dbfiles (append (glob (conc *toppath* "/.mtdb/main.db")) (glob (conc *toppath* "/.mtdb/?.db"))(glob (conc *toppath* "/.mtdb/??.db")))) (ttdat (make-tt areapath: *toppath*)) ) (format #t fmtstr "DB" "host:port" "PID" "age" "last mod" "state") (for-each (lambda (dbfile) (let* ( (dbfname (conc (pathname-file dbfile) ".db")) (sfiles (tt:find-server *toppath* dbfname)) ) (for-each (lambda (sfile) (let ( (sinfos (tt:get-server-info-sorted ttdat dbfname)) ) (for-each (lambda (sinfo) (let* ( (db (list-ref sinfo 5)) (pid (list-ref sinfo 4)) (host (list-ref sinfo 0)) (port (list-ref sinfo 1)) (server-id (list-ref sinfo 3)) (age (seconds->hr-min-sec (- (current-seconds) (list-ref sinfo 2)))) (last-mod (seconds->string (list-ref sinfo 2))) (status (system (conc "ssh " host " ps " pid " > /dev/null"))) (state (if (> status 0) "dead" (tt:ping host port server-id 0) )) ) (format #t fmtstr db (conc host ":" port) pid age last-mod state) ) ) sinfos ) ) ) sfiles ) ) ) dbfiles ) (set! *didsomething* #t) (exit) ) ) (if (args:get-arg "-kill-servers") (let* ((tl (launch:setup)) ;; need this to initialize *toppath* (servdir (tt:get-servinfo-dir *toppath*)) (servfiles (glob (conc servdir "/*:*.db"))) (fmtstr "~10a~22a~10a~25a~25a~8a\n") (dbfiles (if (file-exists? (conc *toppath* "/.mtdb/main.db")) (append (glob (conc *toppath* "/.mtdb/main.db")) (glob (conc *toppath* "/.mtdb/?.db"))(glob (conc *toppath* "/.mtdb/??.db"))) '())) (ttdat (make-tt areapath: *toppath*)) ) (format #t fmtstr "DB" "host:port" "PID" "age" "last mod" "state") (for-each (lambda (dbfile) (let* ( (dbfname (conc (pathname-file dbfile) ".db")) (sfiles (tt:find-server *toppath* dbfname)) ) (for-each (lambda (sfile) (let ( (sinfos (tt:get-server-info-sorted ttdat dbfname)) ) (for-each (lambda (sinfo) (let* ( (db (list-ref sinfo 5)) (pid (list-ref sinfo 4)) (host (list-ref sinfo 0)) (port (list-ref sinfo 1)) (server-id (list-ref sinfo 3)) (age (seconds->hr-min-sec (- (current-seconds) (list-ref sinfo 2)))) (last-mod (seconds->string (list-ref sinfo 2))) (killed (system (conc "ssh " host " kill " pid " > /dev/null"))) (dummy2 (sleep 1)) (state (if (> (system (conc "ssh " host " ps " pid " > /dev/null")) 0) "dead" "alive")) ) (format #t fmtstr db (conc host ":" port) pid age last-mod state) (system (conc "rm " sfile)) ) ) sinfos ) ) ) sfiles ) ) ) dbfiles ) ;; remove this db, because otherwise metadata contains records for old servers, and this causes a problem with db:no-sync-get-lock-with-id. (if (file-exists? (conc *toppath* "/.mtdb/no-sync.db")) (delete-file (conc *toppath* "/.mtdb/no-sync.db")) ) (set! *didsomething* #t) (exit) ) ) ;;====================================================================== ;; Weird special calls that need to run *after* the server has started? ;;====================================================================== (if (args:get-arg "-list-targets") (if (launch:setup) |
︙ | ︙ | |||
1365 1366 1367 1368 1369 1370 1371 | (test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test)) (testname (if (member "testname" tests-spec)(get-value-by-fieldname test test-field-index "testname" ) #f)) ;; (db:test-get-testname test)) (itempath (if (member "item_path" tests-spec)(get-value-by-fieldname test test-field-index "item_path" ) #f)) ;; (db:test-get-item-path test)) (fullname (conc testname (if (equal? itempath "") "" (conc "/" itempath )))) | | | 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 | (test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test)) (testname (if (member "testname" tests-spec)(get-value-by-fieldname test test-field-index "testname" ) #f)) ;; (db:test-get-testname test)) (itempath (if (member "item_path" tests-spec)(get-value-by-fieldname test test-field-index "item_path" ) #f)) ;; (db:test-get-item-path test)) (fullname (conc testname (if (equal? itempath "") "" (conc "/" itempath )))) (testdat-raw (map vector->list (rmt:read-test-data-varpatt run-id test-id categorypatt setvarpatt))) (testdat (filter (lambda (x) (not (equal? "logpro" (list-ref x 10)))) testdat-raw))) (map (lambda (item) |
︙ | ︙ | |||
1399 1400 1401 1402 1403 1404 1405 | ;; NOTE: list-runs and list-db-targets operate on local db!!! ;; ;; IDEA: megatest list -runname blah% ... ;; (if (or (args:get-arg "-list-runs") (args:get-arg "-list-db-targets")) (if (launch:setup) | < | | 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 | ;; NOTE: list-runs and list-db-targets operate on local db!!! ;; ;; IDEA: megatest list -runname blah% ... ;; (if (or (args:get-arg "-list-runs") (args:get-arg "-list-db-targets")) (if (launch:setup) (let* ((runpatt (args:get-arg "-list-runs")) (access-mode (db:get-access-mode)) (testpatt (common:args-get-testpatt #f)) ;; (if (args:get-arg "-testpatt") ;; (args:get-arg "-testpatt") ;; "%")) (keys (rmt:get-keys)) ;; (db:get-keys dbstruct)) ;; (runsdat (db:get-runs dbstruct runpatt #f #f '())) |
︙ | ︙ | |||
1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 | (tests-spec (let ((t (alist-ref "tests" fields-spec equal?))) (if (and t (null? t)) ;; all fields db:test-record-fields t))) (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields))) ;; '("id")))) (steps-spec (alist-ref "steps" fields-spec equal?)) (test-field-index (make-hash-table))) (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec))) (if (null? invalid-tests-spec) ;; generate the lookup map test-field-name => index-number (let loop ((hed (car adj-tests-spec)) (tal (cdr adj-tests-spec)) (idx 0)) | > > > > > | 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 | (tests-spec (let ((t (alist-ref "tests" fields-spec equal?))) (if (and t (null? t)) ;; all fields db:test-record-fields t))) (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields))) ;; '("id")))) (steps-spec (alist-ref "steps" fields-spec equal?)) (test-field-index (make-hash-table))) (if (and (args:get-arg "-dumpmode") (not (member (args:get-arg "-dumpmode") '("sexpr" "json" "ods" "list")))) (begin (debug:print 0 *default-log-port* "ERROR: dumpmode "(args:get-arg "-dumpmode")" not recognised. Use sexpr, json, ods or list") (exit))) (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec))) (if (null? invalid-tests-spec) ;; generate the lookup map test-field-name => index-number (let loop ((hed (car adj-tests-spec)) (tal (cdr adj-tests-spec)) (idx 0)) |
︙ | ︙ | |||
1504 1505 1506 1507 1508 1509 1510 | ;; (mutils:hierhash-set! data (db:get-value-by-header run header "status") targetstr runname "meta" "status" ) ;; (mutils:hierhash-set! data (db:get-value-by-header run header "state") targetstr runname "meta" "state" ) ;; (mutils:hierhash-set! data (conc (db:get-value-by-header run header "id")) targetstr runname "meta" "id" ) ;; (mutils:hierhash-set! data (db:get-value-by-header run header "event_time") targetstr runname "meta" "event_time" ) ;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment") targetstr runname "meta" "comment" ) ;; ;; add last entry twice - seems to be a bug in hierhash? ;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment") targetstr runname "meta" "comment" ) | | | > > > | 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 | ;; (mutils:hierhash-set! data (db:get-value-by-header run header "status") targetstr runname "meta" "status" ) ;; (mutils:hierhash-set! data (db:get-value-by-header run header "state") targetstr runname "meta" "state" ) ;; (mutils:hierhash-set! data (conc (db:get-value-by-header run header "id")) targetstr runname "meta" "id" ) ;; (mutils:hierhash-set! data (db:get-value-by-header run header "event_time") targetstr runname "meta" "event_time" ) ;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment") targetstr runname "meta" "comment" ) ;; ;; add last entry twice - seems to be a bug in hierhash? ;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment") targetstr runname "meta" "comment" ) ((#f list) (if (null? runs-spec) (print "Run: " targetstr "/" runname " status: " (db:get-value-by-header run header "state") " run-id: " run-id ", number tests: " (length tests) " event_time: " (db:get-value-by-header run header "event_time")) (begin (if (not (member "target" runs-spec)) ;; (display (conc "Target: " targetstr)) (display (conc "Run: " targetstr "/" runname " "))) (for-each (lambda (field-name) (if (equal? field-name "target") (display (conc "target: " targetstr " ")) (display (conc field-name ": " (db:get-value-by-header run header (conc field-name)) " ")))) runs-spec) (newline)))) (else (debug:print 0 *default-log-port* "ERROR: dumpmode "(args:get-arg "-dumpmode")" not recognised. Use sexpr, json, ods or list") )) (for-each (lambda (test) (common:debug-handle-exceptions #f exn (begin (debug:print-error 0 *default-log-port* "Bad data in test record? " test) |
︙ | ︙ | |||
1872 1873 1874 1875 1876 1877 1878 | "-runall" "run all tests" (lambda (target runname keys keyvals) (if (or (string-search "%" target) (string-search "%" runname)) ;; we are being asked to re-run multiple runs (let* ((run-specs (rmt:simple-get-runs runname #f #f target #f))) ;; list of simple-run records (debug:print-info 0 *default-log-port* "Pattern supplied for target or runname with " | | | 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 | "-runall" "run all tests" (lambda (target runname keys keyvals) (if (or (string-search "%" target) (string-search "%" runname)) ;; we are being asked to re-run multiple runs (let* ((run-specs (rmt:simple-get-runs runname #f #f target #f))) ;; list of simple-run records (debug:print-info 0 *default-log-port* "Pattern supplied for target or runname with " (length run-specs) " matches found. Running each in turn.") (if (null? run-specs) (debug:print 0 *default-log-port* "WARNING: No runs match target " target " and runname " runname)) (for-each (lambda (spec) (let* ((precmd (if (args:get-arg "-precmd")(conc (args:get-arg "-precmd") " ") "")) (newcmdline (conc precmd (string-substitute |
︙ | ︙ | |||
2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 | (let* ((db #f) ;; DO NOT run remote (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files")))) (for-each (lambda (path) (print path)) paths)))))) ;;====================================================================== ;; Archive tests ;;====================================================================== ;; Archive tests matching target, runname, and testpatt (if (equal? (args:get-arg "-archive") "replicate-db") (begin ;; check if source ;; check if megatest.db exist | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < | | | 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 | (let* ((db #f) ;; DO NOT run remote (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files")))) (for-each (lambda (path) (print path)) paths)))))) ;;====================================================================== ;; Utils for test areas ;;====================================================================== (if (args:get-arg "-regen-testfiles") (if (getenv "MT_TEST_RUN_DIR") (begin (launch:setup) (change-directory (getenv "MT_TEST_RUN_DIR")) (let* ((testname (getenv "MT_TEST_NAME")) (itempath (getenv "MT_ITEMPATH"))) (launch:extract-scripts-logpro (getenv "MT_TEST_RUN_DIR") testname itempath #f)) (set! *didsomething* #t)) (debug:print 0 *default-log-port* "ERROR: Must run -regen-testfiles in a test environment (i.e. test xterm from dashboard)"))) ;;====================================================================== ;; Utils for test areas ;;====================================================================== (if (args:get-arg "-regen-testfiles") (if (getenv "MT_TEST_RUN_DIR") (begin (launch:setup) (change-directory (getenv "MT_TEST_RUN_DIR")) (let* ((testname (getenv "MT_TEST_NAME")) (itempath (getenv "MT_ITEMPATH"))) (launch:extract-scripts-logpro (getenv "MT_TEST_RUN_DIR") testname itempath #f)) (set! *didsomething* #t)) (debug:print 0 *default-log-port* "ERROR: Must run -regen-testfiles in a test environment (i.e. test xterm from dashboard)"))) ;;====================================================================== ;; Archive tests ;;====================================================================== ;; Archive tests matching target, runname, and testpatt (if (equal? (args:get-arg "-archive") "replicate-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:make-tmpdir-name *toppath* "") (> (length (directory (common:make-tmpdir-name *toppath* "") #f)) 0)) (begin (debug:print-info 1 *default-log-port* (common:make-tmpdir-name *toppath* "") " 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"))) |
︙ | ︙ | |||
2072 2073 2074 2075 2076 2077 2078 | ;;====================================================================== (if (args:get-arg "-extract-ods") (general-run-call "-extract-ods" "Make ods spreadsheet" (lambda (target runname keys keyvals) | | | 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 | ;;====================================================================== (if (args:get-arg "-extract-ods") (general-run-call "-extract-ods" "Make ods spreadsheet" (lambda (target runname keys keyvals) (let ((dbstruct (make-dbr:dbstruct areapath: *toppath* local: #t)) (outputfile (args:get-arg "-extract-ods")) (runspatt (or (args:get-arg "-runname")(args:get-arg ":runname"))) (pathmod (args:get-arg "-pathmod"))) ;; (keyvalalist (keys->alist keys "%"))) (debug:print 2 *default-log-port* "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals) (db:extract-ods-file dbstruct outputfile keyvals (if runspatt runspatt "%") pathmod) (db:close-all dbstruct) |
︙ | ︙ | |||
2195 2196 2197 2198 2199 2200 2201 | (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) (if (args:get-arg "-runstep")(debug:print-info 1 *default-log-port* "Running -runstep, first change to directory " work-area)) (change-directory work-area) ;; can setup as client for server mode now | < | 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 | (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) (if (args:get-arg "-runstep")(debug:print-info 1 *default-log-port* "Running -runstep, first change to directory " work-area)) (change-directory work-area) ;; can setup as client for server mode now (if (args:get-arg "-load-test-data") ;; has sub commands that are rdb: ;; DO NOT put this one into either rmt: or open-run-close (tdb:load-test-data run-id test-id)) (if (args:get-arg "-setlog") (let ((logfname (args:get-arg "-setlog"))) |
︙ | ︙ | |||
2329 2330 2331 2332 2333 2334 2335 | (begin (if (not (launch:setup)) (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) ;; keep this one local ;; (open-run-close patch-db #f) | | | > > > > > > | | | 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 | (begin (if (not (launch:setup)) (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) ;; keep this one local ;; (open-run-close patch-db #f) (let ((dbstructs (db:setup))) (common:cleanup-db dbstructs full: #t)) (set! *didsomething* #t))) (if (args:get-arg "-cleanup-db") (begin (if (not (launch:setup)) (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) ;; (if (not (server:choose-server *toppath* 'home?)) ;; (begin ;; (debug:print 0 *default-log-port* "Servers are not running on this host or no servers alive. Cannot run cleanup-db") ;; (exit 1))) (let ((dbstructs (db:setup))) (common:cleanup-db dbstructs)) (set! *didsomething* #t))) (if (args:get-arg "-mark-incompletes") (begin (if (not (launch:setup)) (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") |
︙ | ︙ | |||
2396 2397 2398 2399 2400 2401 2402 | (set! *didsomething* #t) (exit 0))) (if (or (getenv "MT_RUNSCRIPT") (args:get-arg "-repl") (args:get-arg "-load")) (let* ((toppath (launch:setup)) | | | > > | | | > | 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 | (set! *didsomething* #t) (exit 0))) (if (or (getenv "MT_RUNSCRIPT") (args:get-arg "-repl") (args:get-arg "-load")) (let* ((toppath (launch:setup)) (dbstructs (if (and toppath ;; NOTE: server:choose-server is starting a server ;; either add equivalent for tcp mode or ???? #;(server:choose-server toppath 'home?)) (db:setup) #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f))) (if *toppath* (cond ((getenv "MT_RUNSCRIPT") ;; How to run megatest scripts ;; ;; #!/bin/bash ;; ;; export MT_RUNSCRIPT=yes ;; megatest << EOF ;; (print "Hello world") ;; (exit) ;; EOF (repl)) (else (begin (set! *db* dbstructs) (import extras) ;; might not be needed ;; (import csi) (import readline) (import apropos) (import dbfile) ;; (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 |
︙ | ︙ | |||
2486 2487 2488 2489 2490 2491 2492 2493 | ;; ;; ;; redo me (sqlite3:finalize! qry)))) ;; ;; ;; redo me (db:close-all dbstruct) ;; ;; ;; redo me (list "uname" "rundir" "final_logf" "comment")) ;; ;; ;; redo me (set! *didsomething* #t))) (if (args:get-arg "-import-megatest.db") (begin (db:multi-db-sync | > | < | > | > | > | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 | ;; ;; ;; redo me (sqlite3:finalize! qry)))) ;; ;; ;; redo me (db:close-all dbstruct) ;; ;; ;; redo me (list "uname" "rundir" "final_logf" "comment")) ;; ;; ;; redo me (set! *didsomething* #t))) (if (args:get-arg "-import-megatest.db") (begin (launch:setup) (db:multi-db-sync (db:setup) 'killservers 'dejunk 'adj-testids 'old2new ) (set! *didsomething* #t))) (if (args:get-arg "-import-sexpr") (begin (launch:setup) (rmt:import-sexpr (args:get-arg "-import-sexpr")) (set! *didsomething* #t))) (if (args:get-arg "-sync-to-megatest.db") (let* ((duh (launch:setup)) (dbstruct (db:setup)) (tmpdbpth (dbr:dbstruct-tmppath dbstruct)) (lockfile (conc tmpdbpth ".lock")) (locked (common:simple-file-lock lockfile)) (res (if locked (db:multi-db-sync dbstruct 'new2old) #f))) (if res (begin (common:simple-file-release-lock lockfile) (debug:print 0 *default-log-port* "Synced " res " records to megatest.db")) (debug:print 0 *default-log-port* "Skipping sync, there is a sync in progress.")) (set! *didsomething* #t))) (if (args:get-arg "-sync-to") (let ((toppath (launch:setup))) (tasks:sync-to-postgres *configdat* (args:get-arg "-sync-to")) (set! *didsomething* #t))) ;; use with -from and -to ;; (if (args:get-arg "-db2db") (let* ((duh (launch:setup)) (src-db (args:get-arg "-from")) (dest-db (args:get-arg "-to")) ;; (sync-period (args:get-arg-number "-period")) ;; (sync-timeout (args:get-arg-number "-timeout")) (sync-period-in (args:get-arg "-period")) (sync-timeout-in (args:get-arg "-timeout")) (sync-period (if sync-period-in (string->number sync-period-in) #f)) (sync-timeout (if sync-timeout-in (string->number sync-timeout-in) #f)) (lockfile (conc dest-db".sync-lock")) (keys (db:get-keys #f)) (thesync (lambda (last-update) (debug:print-info 0 *default-log-port* "Attempting to sync data from "src-db" to "dest-db"...") (debug:print-info 0 *default-log-port* "PID = " (current-process-id)) (if (not (file-exists? dest-db)) (begin (debug:print 0 *default-log-port* "Using copy to create "dest-db" from "src-db) (file-copy src-db dest-db) 1) (let ((res (dbmod:db-to-db-sync src-db dest-db last-update (dbfile:db-init-proc) keys))) (if res (debug:print-info 2 *default-log-port* "Synced " res " records from "src-db" to "dest-db) (debug:print-info 0 *default-log-port* "No sync due to permissions or other issue.")) res)))) (start-time (current-seconds)) (synclock-mod-time (if (file-exists? lockfile) (handle-exceptions exn #f (file-modification-time synclock-file)) #f)) (age (if synclock-mod-time (- (current-seconds) synclock-mod-time) 1000)) ) (if (and src-db dest-db) (if (file-exists? src-db) (if (and (file-exists? lockfile) (< age 20)) (debug:print 0 *default-log-port* "Lock "lockfile" exists, skipping sync...") (begin (if (file-exists? lockfile) (begin (debug:print 0 *default-log-port* "Deleting old lock file " lockfile) (delete-file lockfile) ) ) (dbfile:with-simple-file-lock lockfile (lambda () (let loop ((last-changed (current-seconds)) (last-update 0)) (let* ((changes (handle-exceptions exn (begin (debug:print 0 *default-log-port* "Exception in sync: "(condition->list exn)) (delete-file lockfile) (exit)) (thesync last-update))) (now-time (current-seconds))) (if (and sync-period sync-timeout) ;; (if (and (< (- now-time start-time) 600) ;; hard limit on how long we run for (> sync-timeout (- now-time last-changed))) (begin (if sync-period (thread-sleep! sync-period)) (loop (if (> changes 0) now-time last-changed) now-time)))))))) (debug:print 0 *default-log-port* "Releasing lock file " lockfile) ) ) (debug:print 0 *default-log-port* "No sync due to unreadble or non-existant source file"src-db)) (debug:print 0 *default-log-port* "Usage for -db2db; -to and -from must be specified")) (set! *didsomething* #t))) (if (args:get-arg "-list-test-time") (let* ((toppath (launch:setup))) (task:get-test-times) (set! *didsomething* #t))) (if (args:get-arg "-list-run-time") (let* ((toppath (launch:setup))) |
︙ | ︙ | |||
2572 2573 2574 2575 2576 2577 2578 | (set! *time-to-exit* #t) ) ;;(debug:print-info 13 *default-log-port* "thread-join! watchdog") ;; join the watchdog thread if it has been thread-start!ed (it may not have been started in the case of a server that never enters running state) ;; (symbols returned by thread-state: created ready running blocked suspended sleeping terminated dead) ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage | | | | | | 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 | (set! *time-to-exit* #t) ) ;;(debug:print-info 13 *default-log-port* "thread-join! watchdog") ;; join the watchdog thread if it has been thread-start!ed (it may not have been started in the case of a server that never enters running state) ;; (symbols returned by thread-state: created ready running blocked suspended sleeping terminated dead) ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage ;;(if (thread? *watchdog*) ;; (case (thread-state *watchdog*) ;; ((ready running blocked sleeping terminated dead) ;; (thread-join! *watchdog*)))) (set! *time-to-exit* #t) (if (not (eq? *globalexitstatus* 0)) (if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall")) (begin (debug:print 0 *default-log-port* "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*) (exit 0)) (case *globalexitstatus* ((0)(exit 0)) ((1)(exit 1)) ((2)(exit 2)) (else (exit 3))))) |
Modified monitor.scm from [3df55c85ea] to [3205ec8bdb].
︙ | ︙ | |||
21 22 23 24 25 26 27 28 29 30 31 32 33 | (import (prefix sqlite3 sqlite3:)) (declare (unit runs)) (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") | > > | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 | (import (prefix sqlite3 sqlite3:)) (declare (unit runs)) (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) (declare (uses commonmod)) (import commonmod) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") |
Modified mt.scm from [e9055c2687] to [9ff41cb92d].
︙ | ︙ | |||
17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | ;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils call-with-environment-variables) (import (prefix sqlite3 sqlite3:)) (declare (unit mt)) (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) (declare (uses tests)) (declare (uses server)) (declare (uses runs)) (declare (uses rmt)) | > | > > > | 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 | ;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils call-with-environment-variables) (import (prefix sqlite3 sqlite3:)) (declare (unit mt)) (declare (uses debugprint)) (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) (declare (uses tests)) (declare (uses server)) (declare (uses runs)) (declare (uses rmt)) (declare (uses rmtmod)) (import debugprint rmtmod) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") |
︙ | ︙ | |||
135 136 137 138 139 140 141 | res) (cons testn res))))))))) ;;====================================================================== ;; T R I G G E R S ;;====================================================================== | | > > > | > > > > > > > > > > > > > | > | < < < | | > > | 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 | res) (cons testn res))))))))) ;;====================================================================== ;; T R I G G E R S ;;====================================================================== (define (mt:run-trigger cmd test-id test-rundir trigger logname test-name item-path event-time actual-state actual-status target runname) ;; Putting the commandline into ( )'s means no control over the shell. ;; stdout and stderr will be caught in the NBFAKE or mt_launch.log files ;; or equivalent. No need to do this. Just run it? (let* ((new-trigger-format (configf:lookup *configdat* "setup" "new-trigger-format")) (fullcmd (if (and new-trigger-format (string=? new-trigger-format "yes")) (conc "nbfake " cmd " " test-id " " test-rundir " " trigger " " actual-state " " actual-status " " event-time " " target " " runname " " test-name " " item-path ) (conc "nbfake " cmd " " test-id " " test-rundir " " trigger " " test-name " " item-path " " actual-state " " actual-status " " event-time ) )) (prev-nbfake-log (get-environment-variable "NBFAKE_LOG"))) (setenv "NBFAKE_LOG" (conc (cond ((and (directory-exists? test-rundir) (file-write-access? test-rundir)) test-rundir) ((and (directory-exists? *toppath*) (file-write-access? *toppath*)) *toppath*) (else (conc "/tmp/" (current-user-name)))) "/" logname)) (debug:print-info 0 *default-log-port* "TRIGGERED on " trigger ", running command " fullcmd " output at " (get-environment-variable "NBFAKE_LOG")) (process-run fullcmd) (if prev-nbfake-log (setenv "NBFAKE_LOG" prev-nbfake-log) (unsetenv "NBFAKE_LOG")) )) (define (mt:process-triggers dbstruct run-id test-id newstate newstatus) (if test-id (let* ((test-dat (db:get-test-info-by-id dbstruct run-id test-id))) (if test-dat (let* ((test-rundir (db:test-get-rundir test-dat)) ;; ) ;; ) (test-name (db:test-get-testname test-dat)) (item-path (db:test-get-item-path test-dat)) (duration (db:test-get-run_duration test-dat)) (comment (db:test-get-comment test-dat)) (event-time (db:test-get-event_time test-dat)) (tconfig #f) (state (if newstate newstate (db:test-get-state test-dat))) (status (if newstatus newstatus (db:test-get-status test-dat))) (target (getenv "MT_TARGET")) (runname (getenv "MT_RUNNAME"))) ;; (mutex-lock! *triggers-mutex*) (handle-exceptions exn (begin (debug:print-error 0 *default-log-port* " Exception in mt:process-triggers for run-id="run-id" test-id="test-id" newstate="newstate" newstatus="newstatus "\n error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn "\n test-rundir="test-rundir |
︙ | ︙ | |||
215 216 217 218 219 220 221 | (push-directory *toppath*)) (set! tconfig (mt:lazy-read-test-config test-name)) (for-each (lambda (trigger) (let* ((munged-trigger (string-translate trigger "/ " "--")) (logname (conc "last-trigger-" munged-trigger ".log"))) ;; first any triggers from the testconfig (let ((cmd (configf:lookup tconfig "triggers" trigger))) | | | | 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 | (push-directory *toppath*)) (set! tconfig (mt:lazy-read-test-config test-name)) (for-each (lambda (trigger) (let* ((munged-trigger (string-translate trigger "/ " "--")) (logname (conc "last-trigger-" munged-trigger ".log"))) ;; first any triggers from the testconfig (let ((cmd (configf:lookup tconfig "triggers" trigger))) (if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "tconfig-" logname) test-name item-path event-time state status target runname))) ;; next any triggers from megatest.config (let ((cmd (configf:lookup *configdat* "triggers" trigger))) (if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "mtconfig-" logname) test-name item-path event-time state status target runname))))) (list (conc state "/" status) (conc state "/") (conc "/" status))) (pop-directory)) ))) ;; (mutex-unlock! *triggers-mutex*) |
︙ | ︙ |
Modified mtargs.scm from [1e6b59e54f] to [22cf29b180].
︙ | ︙ | |||
15 16 17 18 19 20 21 22 23 | ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit mtargs)) (include "mtargs/mtargs.scm") | > > | 15 16 17 18 19 20 21 22 23 24 25 | ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit mtargs)) (use srfi-69) (include "mtargs/mtargs.scm") |
Added mtargs/mtargs.egg version [deacd4afda].
> > > > > > > | 1 2 3 4 5 6 7 | ((license "LGPL") (version 0.1) (category misc) (dependencies srfi-69 srfi-1) (author "Matt Welland") (synopsis "Primitive argument processor.") (components (extension mtargs))) |
Modified mtargs/mtargs.scm from [e2f1c247b7] to [c1d2bd2b3a].
︙ | ︙ | |||
16 17 18 19 20 21 22 | ;; along with mtargs. If not, see <http://www.gnu.org/licenses/>. (module mtargs ( arg-hash get-arg | | | > > < | > | > > > | > > > > < > > > > > > > > > > | | < < < < < > | 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 | ;; along with mtargs. If not, see <http://www.gnu.org/licenses/>. (module mtargs ( arg-hash get-arg get-arg-number get-arg-from remove-arg-from-ht get-args usage print-args any-defined? ) (import scheme) ;; gives us cond-expand in chicken-4 (cond-expand (chicken-5 (import scheme (chicken base) (chicken port) (chicken file) (chicken process-context)) (import srfi-69 srfi-1)) (chicken-4 (import chicken posix srfi-69 srfi-1)) (else)) (define usage (make-parameter print)) (define arg-hash (make-hash-table)) (define (get-arg arg . default) (if (null? default) (hash-table-ref/default arg-hash arg #f) (hash-table-ref/default arg-hash arg (car default)))) ;; get an arg as a number (define (get-arg-number arg . default) (let* ((val-str (get-arg arg)) (val (if val-str (string->number val-str) #f))) (if val val (if (null? default) #f default)))) (define (any-defined? . args) (not (null? (filter (lambda (x) x) (map get-arg args))))) ;; (define any any-defined?) (define (get-arg-from ht arg . default) (if (null? default) (hash-table-ref/default ht arg #f) (hash-table-ref/default ht arg (car default)))) (define (remove-arg-from-ht arg) (hash-table-delete! arg-hash arg) ) (define (get-args args params switches arg-hash num-needed) (let* ((numtargs (length args)) (adj-num-needed (if num-needed (+ num-needed 2) #f))) (if (< numtargs (if adj-num-needed adj-num-needed 2)) (if (>= num-needed 1) (usage "No arguments provided") |
︙ | ︙ | |||
82 83 84 85 86 87 88 | (if (null? tail) remtargs (loop (car tail)(cdr tail) remtargs))) (else (if (null? tail)(append remtargs (list arg)) ;; return the non-used args (loop (car tail)(cdr tail)(append remtargs (list arg)))))))) )) | | < > > > | > | 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 | (if (null? tail) remtargs (loop (car tail)(cdr tail) remtargs))) (else (if (null? tail)(append remtargs (list arg)) ;; return the non-used args (loop (car tail)(cdr tail)(append remtargs (list arg)))))))) )) (define (print-args arg-hash) (for-each (lambda (arg) (print " " arg " " (hash-table-ref/default arg-hash arg #f))) (hash-table-keys arg-hash))) (define (any-defined? . args) (not (null? (filter (lambda (x) x) (map get-arg args))))) ) |
Modified mtexec.scm from [6016ee8684] to [fd5a49b5a6].
︙ | ︙ | |||
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 mtargs)) (declare (uses configf)) ;; (declare (uses rmt)) (declare (uses commonmod)) (import commonmod (prefix mtargs args:)) ;; (use ducttape-lib) (include "megatest-version.scm") (include "megatest-fossil-hash.scm") ;; (require-library stml) |
︙ | ︙ |
Modified mtut.scm from [cc88551c71] to [156220c91d].
︙ | ︙ | |||
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 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 | ;; 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 (uses common)) (declare (uses mtargs)) (declare (uses mtargs.import)) (declare (uses debugprint)) (declare (uses debugprint.import)) (declare (uses configf)) ;; (declare (uses rmt)) (declare (uses commonmod)) (declare (uses commonmod.import)) (import debugprint) ; (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 pkts regex regex-case (prefix dbi dbi:) (prefix sqlite3 sqlite3:) nanomsg) (import commonmod (prefix mtargs args:)) (use ducttape-lib) (include "megatest-fossil-hash.scm") (require-library stml) ;; stuff for the mapper and checker functions ;; (define *target-mappers* (make-hash-table)) (define *runname-mappers* (make-hash-table)) (define *area-checkers* (make-hash-table)) |
︙ | ︙ | |||
480 481 482 483 484 485 486 | (args:get-arg "-envcap") (args:get-arg "-envdelta") (member *action* '("db" "tsend" "tlisten")) ;; very loose checks on db and tsend/listen (equal? *action* "show") ;; just keep going if list ))) (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " "))) | | | 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 | (args:get-arg "-envcap") (args:get-arg "-envdelta") (member *action* '("db" "tsend" "tlisten")) ;; very loose checks on db and tsend/listen (equal? *action* "show") ;; just keep going if list ))) (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " "))) (if (or (args:any-defined? "-h" "help" "-help" "--help") (member *action* '("-h" "-help" "--help" "help"))) (begin (print help) (exit 1))) ;;====================================================================== ;; Nanomsg transport |
︙ | ︙ | |||
1398 1399 1400 1401 1402 1403 1404 | (set! ret #f)) (if (string-contains cmd "-modepatt") (if (check-if-modepatt-defined pkta notification-hook pktfile) (print "Modepatt is valid") (set! ret #f)))) ret)) | | > | 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 | (set! ret #f)) (if (string-contains cmd "-modepatt") (if (check-if-modepatt-defined pkta notification-hook pktfile) (print "Modepatt is valid") (set! ret #f)))) ret)) ;; collect all needed data and create run pkts for contours with changed inputs ;; (define (dispatch-commands mtconf toppath) ;; we are expecting a directory "logs", check and create it, create the log in /tmp if not able to create logs dir (let ((logdir (if (if (not (directory? "logs")) (handle-exceptions |
︙ | ︙ | |||
1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 | (let* ((rgconfdat (find-and-read-config (conc toppath "/runconfigs.config"))) (rgconf (car rgconfdat)) (areas (configf:get-section mtconf "areas")) (contours (configf:get-section mtconf "contours")) (pkts (find-pkts pdb '(cmd) '())) (torun (make-hash-table)) ;; target => ( ... info ... ) (rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering (sqlite3:set-busy-handler! (dbi:db-conn pdb) (sqlite3:make-busy-timeout 10000)) (for-each (lambda (pktdat) (let* ((pkta (alist-ref 'apkt pktdat)) (action (alist-ref 'A pkta)) (cmdline (pkt->cmdline pkta)) (uuid (alist-ref 'Z pkta)) | > | 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 | (let* ((rgconfdat (find-and-read-config (conc toppath "/runconfigs.config"))) (rgconf (car rgconfdat)) (areas (configf:get-section mtconf "areas")) (contours (configf:get-section mtconf "contours")) (pkts (find-pkts pdb '(cmd) '())) (torun (make-hash-table)) ;; target => ( ... info ... ) (rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering (debug:print 0 *default-log-port* "dispatch-commands: number of pkts = " (length pkts)) (sqlite3:set-busy-handler! (dbi:db-conn pdb) (sqlite3:make-busy-timeout 10000)) (for-each (lambda (pktdat) (let* ((pkta (alist-ref 'apkt pktdat)) (action (alist-ref 'A pkta)) (cmdline (pkt->cmdline pkta)) (uuid (alist-ref 'Z pkta)) |
︙ | ︙ | |||
1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 | (system notification-cmd)))) (begin ;; if modepatt used chek if it is defined for the target. If -reqtarg check if target exist. (if (validate-cmd fullcmd pkta notification-hook pktfile) (begin (print "RUNNING: " fullcmd) (system fullcmd) ;; replace with process ... (mark-processed pdb (list (alist-ref 'id pktdat))) (let-values (((ack-uuid ack-pkt) (add-z-card (construct-sdat 'P uuid 'T (case (string->symbol action) ((run) "runstart") ((sync) "syncstart") ;; example of translating run -> runstart (else action)) | > > > | 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 | (system notification-cmd)))) (begin ;; if modepatt used chek if it is defined for the target. If -reqtarg check if target exist. (if (validate-cmd fullcmd pkta notification-hook pktfile) (begin (print "RUNNING: " fullcmd) (system fullcmd) ;; replace with process ... (debug:print 0 *default-log-port* "doing mark-processed. pktsdir: " pktsdir) (debug:print 0 *default-log-port* "fullcmd: " fullcmd) (mark-processed pdb (list (alist-ref 'id pktdat))) (thread-sleep! 100) (let-values (((ack-uuid ack-pkt) (add-z-card (construct-sdat 'P uuid 'T (case (string->symbol action) ((run) "runstart") ((sync) "syncstart") ;; example of translating run -> runstart (else action)) |
︙ | ︙ |
Modified newdashboard.scm from [3cc17ecae4] to [e167b54c9d].
︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | ;; 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/>. ;;====================================================================== (use format) (use (prefix iup iup:)) (use canvas-draw) (import canvas-draw-iup) (use sql-de-lite srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors ;; defstruct (prefix dbi dbi:)) | > > > > > > | | | < | 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 | ;; 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 (uses common)) (declare (uses debugprint)) (declare (uses megatest-version)) (declare (uses mtargs)) (declare (uses commonmod)) (use format) (use (prefix iup iup:)) (use canvas-draw) (import canvas-draw-iup) (use sql-de-lite srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors ;; defstruct (prefix dbi dbi:)) (import commonmod debugprint (prefix mtargs args:)) ;; (declare (uses launch)) ;; (declare (uses gutils)) ;; (declare (uses db)) ;; (declare (uses server)) (declare (uses dcommon)) ;; (declare (uses tree)) ;; ;; (include "common_records.scm") ;; (include "db_records.scm") ;; (include "key_records.scm") |
︙ | ︙ | |||
414 415 416 417 418 419 420 | #:expand "YES" ;; #:scrollbar "YES" #:numcol 1 #:numlin 4 #:numcol-visible 1 #:numlin-visible 4 #:click-cb (lambda (obj lin col status) | > | > | 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 | #:expand "YES" ;; #:scrollbar "YES" #:numcol 1 #:numlin 4 #:numcol-visible 1 #:numlin-visible 4 #:click-cb (lambda (obj lin col status) #f ;;(print "obj: " obj " lin: " lin " col: " col " status: " status) ))) (test-info-matrix (iup:matrix #:expand "YES" #:numcol 1 #:numlin 7 #:numcol-visible 1 #:numlin-visible 7)) (test-run-matrix (iup:matrix |
︙ | ︙ | |||
553 554 555 556 557 558 559 | (lambda (obj id state) ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((run-path (tree:node->path obj id)) (test-id (tree-path->test-id (cdr run-path)))) ;; (if test-id ;; (hash-table-set! (dboard:data-curr-test-ids *data*) ;; window-id test-id)) | | > | 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 | (lambda (obj id state) ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((run-path (tree:node->path obj id)) (test-id (tree-path->test-id (cdr run-path)))) ;; (if test-id ;; (hash-table-set! (dboard:data-curr-test-ids *data*) ;; window-id test-id)) ;; (print "path: " (tree:node->path obj id) " test-id: " test-id) ))))) (iup:attribute-set! tb "VALUE" "0") (iup:attribute-set! tb "NAME" "Runs") ;;(iup:attribute-set! tb "ADDEXPANDED" "NO") ;; (dboard:data-tests-tree-set! *data* tb) tb) (test-panel window-id))) |
︙ | ︙ | |||
661 662 663 664 665 666 667 | ;; #:fittosize "YES" #:scrollbar "YES" #:numcol 100 #:numlin 100 #:numcol-visible 7 #:numlin-visible 7 #:click-cb (lambda (obj lin col status) | > | > | 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 | ;; #:fittosize "YES" #:scrollbar "YES" #:numcol 100 #:numlin 100 #:numcol-visible 7 #:numlin-visible 7 #:click-cb (lambda (obj lin col status) #f ;; (print "obj: " obj " lin: " lin " col: " col " status: " status) )))) (iup:attribute-set! runs-matrix "RESIZEMATRIX" "YES") (iup:attribute-set! runs-matrix "WIDTH0" "100") ;; (dboard:data-runs-matrix-set! *data* runs-matrix) (iup:hbox (iup:frame |
︙ | ︙ |
Modified ods.scm from [42e94b826f] to [1b93bc9256].
︙ | ︙ | |||
15 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/>. ;; (use csv-xml regex) (declare (unit ods)) (declare (uses common)) (define ods:dirs '("Configurations2" "Configurations2/toolpanel" "Configurations2/menubar" "Configurations2/toolbar" "Configurations2/progressbar" | > > | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; (use csv-xml regex) (declare (unit ods)) (declare (uses common)) (declare (uses commonmod)) (import commonmod) (define ods:dirs '("Configurations2" "Configurations2/toolpanel" "Configurations2/menubar" "Configurations2/toolbar" "Configurations2/progressbar" |
︙ | ︙ |
Modified portlogger.scm from [36a4964f50] to [36890e0c14].
︙ | ︙ | |||
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/>. ;; (require-extension (srfi 18) extras tcp s11n) | > > > | > > > > > > > > > > > > > > | > | > > > > > > > > > > > | > > > > > | > > > > | > | | < | | | | | 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 | ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; (require-extension (srfi 18) extras tcp s11n) (declare (unit portlogger)) (declare (uses debugprint)) (declare (uses dbmod)) (module portlogger * (import scheme) (cond-expand (chicken-4 (import chicken data-structures) (import posix ;; hostinfo ;; dot-locking extras ) (import (prefix sqlite3 sqlite3:)) (import debugprint dbmod) ) (chicken-5 (import chicken.base chicken.condition chicken.file chicken.pathname chicken.process-context.posix chicken.process chicken.sort chicken.string chicken.time chicken.random system-information ) (define file-write-access? file-writable?) (define random pseudo-random-integer) )) (import srfi-1 srfi-69 z3 (srfi 18) s11n) (import (prefix sqlite3 sqlite3:)) (import debugprint dbmod) ;; lsof -i (define (portlogger:open-db fname) (let* (;; (avail (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away (avail #t) (exists (file-exists? fname)) (db (if avail (sqlite3:open-database fname) (begin (system (conc "rm -f " fname)) (sqlite3:open-database fname)))) (handler (sqlite3:make-busy-timeout 136000)) (canwrite (file-write-access? fname))) ;; (db-init (lambda () ;; (sqlite3:execute ;; db ;; "CREATE TABLE IF NOT EXISTS ports ( ;; port INTEGER PRIMARY KEY, ;; state TEXT DEFAULT 'not-used', ;; fail_count INTEGER DEFAULT 0, ;; update_time TIMESTAMP DEFAULT (strftime('%s','now')) );")))) (sqlite3:set-busy-handler! db handler) (sqlite3:execute db "PRAGMA synchronous = 0;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS ports ( port INTEGER PRIMARY KEY, state TEXT DEFAULT 'not-used', fail_count INTEGER DEFAULT 0, update_time TIMESTAMP DEFAULT (strftime('%s','now')) );") db)) (define (portlogger:open-run-close proc . params) (let* ((fname (conc "/tmp/." (current-user-name) "-portlogger.db"))) ;; (avail (tasks:wait-on-journal fname 10))) ;; wait up to about 10 seconds for the journal to go away (handle-exceptions exn (begin ;; (release-dot-lock fname) (debug:print-error 0 *default-log-port* "portlogger:open-run-close failed. " proc " " params) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) ;; (debug:print 5 *default-log-port* "exn=" (condition->list exn)) (if (file-exists? fname)(delete-file fname)) ;; brutally get rid of it (print-call-chain (current-error-port))) (let* (;; (lock (obtain-dot-lock fname 2 9 10)) (db (portlogger:open-db fname)) (res (apply proc db params))) (sqlite3:finalize! db) ;; (release-dot-lock fname) res)))) |
︙ | ︙ | |||
120 121 122 123 124 125 126 | (sqlite3:fold-row (lambda (var curr) (or curr var curr)) #f db "SELECT (port) FROM ports WHERE state='released' LIMIT 1;"))) | | < < < < < | | 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 | (sqlite3:fold-row (lambda (var curr) (or curr var curr)) #f db "SELECT (port) FROM ports WHERE state='released' LIMIT 1;"))) (define (portlogger:find-port db #!optional (lowport 32768)) (let* ((portnum (or (portlogger:get-prev-used-port db) (+ lowport ;; top of registered ports is 49152 but lets use ports in the registered range (random (- 64000 lowport)))))) (handle-exceptions exn (begin (debug:print 0 *default-log-port* "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db") (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) |
︙ | ︙ | |||
182 183 184 185 186 187 188 | state) state)) ((failed)(portlogger:set-failed db (string->number (cadr args))) 'failed))))) (sqlite3:finalize! db) result)) ;; (print (apply portlogger:main (cdr (argv)))) | > | 215 216 217 218 219 220 221 222 | state) state)) ((failed)(portlogger:set-failed db (string->number (cadr args))) 'failed))))) (sqlite3:finalize! db) result)) ;; (print (apply portlogger:main (cdr (argv)))) ) |
Modified process.scm from [f9dfbe5500] to [4050043a66].
︙ | ︙ | |||
20 21 22 23 24 25 26 27 28 29 30 31 32 33 | ;;====================================================================== ;; Process convience utils ;;====================================================================== (use regex directory-utils) (declare (unit process)) (define (process:conservative-read port) (let loop ((res "")) (if (not (eof-object? (peek-char port))) (loop (conc res (read-char port))) res))) | > > > | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | ;;====================================================================== ;; Process convience utils ;;====================================================================== (use regex directory-utils) (declare (unit process)) (declare (uses debugprint)) (import debugprint) (define (process:conservative-read port) (let loop ((res "")) (if (not (eof-object? (peek-char port))) (loop (conc res (read-char port))) res))) |
︙ | ︙ | |||
83 84 85 86 87 88 89 | (list result (if normalexit? exitstatus -1)))))))) (define (process:cmd-run-proc-each-line cmd proc . params) ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params) (handle-exceptions exn (begin | | | 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 | (list result (if normalexit? exitstatus -1)))))))) (define (process:cmd-run-proc-each-line cmd proc . params) ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params) (handle-exceptions exn (begin (debug:print 0 *default-log-port* "ERROR: Failed to run command: " cmd " " (string-intersperse params " ")) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 5 *default-log-port* "exn=" (condition->list exn)) #f) (let-values (((fh fho pid) (if (null? params) (process cmd) (process cmd params)))) (let loop ((curr (read-line fh)) |
︙ | ︙ | |||
193 194 195 196 197 198 199 | (common:file-exists? (conc "/proc/" pid)) (let-values (((rpid exit-type exit-signal)(process-wait pid #t))) (and (number? rpid) (equal? rpid pid))))) (define (process:alive-on-host? host pid) (let ((cmd (conc "ssh " host " ps -o pid= -p " pid))) | > > > | | | | | | | | | | | | | | | > > > > > | 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 | (common:file-exists? (conc "/proc/" pid)) (let-values (((rpid exit-type exit-signal)(process-wait pid #t))) (and (number? rpid) (equal? rpid pid))))) (define (process:alive-on-host? host pid) (let ((cmd (conc "ssh " host " ps -o pid= -p " pid))) (common:generic-ssh cmd ;; ;; handle-exceptions ;; exn ;; (begin ;; (debug:print 0 *default-log-port* "failed to identify if process " pid ", on host " host " is alive. exn=" exn) ;; #f) ;; anything goes wrong - assume the process in NOT running. ;; (with-input-from-pipe ;; cmd (lambda () (let loop ((inl (read-line))) (if (eof-object? inl) #f (let* ((clean-str (string-substitute "^[^\\d]*([0-9]+)[^\\d]*$" "\\1" inl)) (innum (string->number clean-str))) (and innum (eq? pid innum)))))) #f (lambda () (debug:print 0 *default-log-port* "failed to identify if process " pid", on host "host" is alive. exn="exn))))) (define (process:get-sub-pids pid) (with-input-from-pipe (conc "pstree -A -p " pid) ;; | tr 'a-z\\-+`()\\.' ' ' " pid) (lambda () (let loop ((inl (read-line)) (res '())) (if (eof-object? inl) (reverse res) (let ((nums (map string->number (string-split-fields "\\d+" inl)))) (loop (read-line) (append res nums)))))))) |
Modified rmt.scm from [9f2b8feba3] to [d8fa815575].
︙ | ︙ | |||
17 18 19 20 21 22 23 24 | ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;;====================================================================== (use format typed-records) ;; RADT => purpose of json format?? (declare (unit rmt)) (declare (uses api)) | > > > | > < < | > | > > > > > > > < < < | | | | > > | | < | > > | | > > | < < | < < | < < < < < < < < < < < < | < < < | < < < < < | < < < < < < | < | > > > > | | < < < < < < < < | < < < < < < < < < < | < < < < < < < < | < < < < < < < | < < > | < < | < < | < < < < < < < | < < | < < < < | | < < < < < > > > < < < < < < < < < < < < < | < < < > > > | > | < < < < > > > | < | < < < < < < < < < < < < < | < < < < < < < < < < | | < < < < < < < < < < < < < | < < < < < | < < < | < | | < < | | < < | < < < < < < < < < | < < < < < | < | < < | < | < | | | | | | < | < | < > > > | < < | | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < | < < < < < < < < < < < > > | | 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 | ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;;====================================================================== (use format typed-records) ;; RADT => purpose of json format?? (declare (unit rmt)) (declare (uses debugprint)) (declare (uses api)) (declare (uses commonmod)) (declare (uses dbfile)) (declare (uses dbmod)) (declare (uses tcp-transportmod)) (include "common_records.scm") (declare (uses rmtmod)) ;; used by http-transport (import dbfile rmtmod commonmod debugprint ;; dbmemmod dbfile dbmod tcp-transportmod) ;; ;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!! ;; ;; generate entries for ~/.megatestrc with the following ;; ;; grep define ../rmt.scm | grep rmt: |perl -pi -e 's/\(define\s+\((\S+)\W.*$/\1/'|sort -u ;;====================================================================== ;; S U P P O R T F U N C T I O N S ;;====================================================================== (define (rmt:on-homehost? runremote) (let* ((hh-dat (remote-hh-dat runremote))) (if (pair? hh-dat) (cdr hh-dat) (begin (debug:print-info 0 *default-log-port* "hh-dat="hh-dat) #f)))) (define (make-and-init-remote areapath) (case (rmt:transport-mode) ((http)(make-remote)) ((tcp) (tt:make-remote areapath)) (else #f))) ;;====================================================================== (define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id (define *ttdat* #f) ;; how to make area-dat (define (rmt:set-ttdat areapath ttdat) (if ttdat ttdat (if *ttdat* *ttdat* (begin (debug:print-info 2 *default-log-port* "rmt:set-ttdat: Initialize new ttdat") (let* ((newremote (make-and-init-remote areapath))) (set! *ttdat* newremote) newremote ) ) ) ) ) ;; NB// area-dat replaced by ttdat ;; (define (rmt:send-receive cmd run-id params #!key (attemptnum 1)(ttdat #f)) (assert (or (not run-id) (number? run-id)) "FATAL: run-id is required to be a number or #f") (assert *toppath* "FATAL: rmt:send-receive called with *toppath* not set.") (let* ((areapath *toppath*) ;; TODO - resolve from dbstruct to be compatible with multiple areas (readonly-mode (rmtmod:calc-ro-mode ttdat *toppath*)) (testsuite (common:get-testsuite-name)) (dbfname (conc (dbfile:run-id->dbnum run-id)".db")) (dbdir (conc areapath "/.mtdb")) (journal-check #f)) ;; disabling journal check for now, since journal files are only possible on the NFS dbs. (if (and journal-check (not *journal-stats*) (file-exists? dbdir)) (tt:start-stats dbdir)) ;; fixme - find the right call to get the db directory ;; check the load on dbfname and add some delay using a droop curve of sorts (if (and journal-check *journal-stats*) (let* ((load (tt:get-journal-stats dbfname))) (if (> load 0.1) ;; start activating delay at 10% journal load time (let ((dely (* 50 (* load load)))) ;; 100% journal time=50sec delay (debug:print 0 *default-log-port* "Journal load "load" on "dbfname" delaying queries "dely"s.") (thread-sleep! dely))))) (case (rmt:transport-mode) ((tcp) (let* ((start-time (current-seconds)) ;; snapshot time so all use cases get same value (attemptnum (+ 1 attemptnum)) (mtexe (common:find-local-megatest)) (ttdat (rmt:set-ttdat areapath ttdat)) (conn (tt:get-conn ttdat dbfname)) (is-main (equal? dbfname "main.db")) ;; why not (not run-id) ? (server-start-proc (if is-main #f (lambda () ;; (debug:print-info 0 *default-log-port* "starting server for dbfname: "dbfname) (rmt:start-server ;; tt:server-process-run areapath testsuite ;; (dbfile:testsuite-name) mtexe run-id))))) ;; here we look at ttdat, if dbfname is NOT main.db we check that a conn exists for it ;; and if there is no conn we first send a request to the main.db server to start a ;; server for the dbfname. #;(if (and (not is-main)(not conn)) ;; no existing connection to non-main server, call in a start up request (begin (server-start-proc) (thread-sleep! 1))) (tt:handler ttdat cmd run-id params attemptnum readonly-mode dbfname testsuite mtexe server-start-proc))) ((nfs) (nfs-transport-handler cmd run-id params attemptnum areapath readonly-mode testsuite)) (else (debug:print-info 0 *default-log-port* "rmt:transport-mode is "(rmt:transport-mode)) (assert #f "FATAL: rmt:transport-mode set to invalid value."))))) (define (nfs-transport-handler cmd run-id params attemptnum areapath readonly-mode testsuite) (let* ((keys (common:get-fields *configdat*)) (dbstruct (dbmod:nfs-get-dbstruct run-id keys (dbfile:db-init-proc) areapath))) (api:dispatch-request dbstruct cmd run-id params))) (define (rmt:get-max-query-average run-id) (mutex-lock! *db-stats-mutex*) (let* ((runkey (conc "run-id=" run-id " ")) (cmds (filter (lambda (x) (substring-index runkey x)) (hash-table-keys *db-stats*))) (res (if (null? cmds) |
︙ | ︙ | |||
372 373 374 375 376 377 378 | (cons newmax-cmd currmax) (cons 'none 0)) (loop (car tal)(cdr tal) newmax-cmd currmax))))))) (mutex-unlock! *db-stats-mutex*) res)) (define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5)) | | | | | | | | | | | | | | | | | | | | | | 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 | (cons newmax-cmd currmax) (cons 'none 0)) (loop (car tal)(cdr tal) newmax-cmd currmax))))))) (mutex-unlock! *db-stats-mutex*) res)) (define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5)) (let* ((qry-is-write (not (member cmd api:read-only-queries))) (db-file-path (common:make-tmpdir-name *toppath* "")) ;; 0)) (dbstructs-local (db:setup)) (read-only (not (file-write-access? db-file-path))) (start (current-milliseconds)) (resdat (if (not (and read-only qry-is-write)) (let ((v (api:execute-requests dbstructs-local (vector (symbol->string cmd) params)))) ;; (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong.. ;; exn ;; This is an attempt to detect that situation and recover gracefully ;; (begin ;; (debug:print 0 *default-log-port* "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) ;; (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy (if (and (vector? v) (> (vector-length v) 1)) (let ((newvec (vector (vector-ref v 0)(vector-ref v 1)))) newvec) ;; by copying the vector while inside the error handler we should force the detection of a corrupted record (vector #t '()))) ;; ) ;; we could also check that the returned types are valid (vector #t '()))) (success (vector-ref resdat 0)) (res (vector-ref resdat 1)) (duration (- (current-milliseconds) start))) (if (and read-only qry-is-write) (debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd)) (if (not success) (if (> remretries 0) (begin (debug:print-error 0 *default-log-port* "local query failed. Trying again.") |
︙ | ︙ | |||
414 415 416 417 418 419 420 | (if qry-is-write (let ((start-time (current-seconds))) (mutex-lock! *db-multi-sync-mutex*) (set! *db-last-access* start-time) ;; THIS IS PROBABLY USELESS? (we are on a client) (mutex-unlock! *db-multi-sync-mutex*))))) res)) | < < < < < < < < < < < < | | | | < < < < | < < < < < | | | > > > > > > > > > > > > | | 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 | (if qry-is-write (let ((start-time (current-seconds))) (mutex-lock! *db-multi-sync-mutex*) (set! *db-last-access* start-time) ;; THIS IS PROBABLY USELESS? (we are on a client) (mutex-unlock! *db-multi-sync-mutex*))))) res)) ;;====================================================================== ;; ;; A C T U A L A P I C A L L S ;; ;;====================================================================== ;;====================================================================== ;; S E R V E R ;;====================================================================== (define (rmt:kill-server run-id) (rmt:send-receive 'kill-server run-id (list run-id))) (define (rmt:start-server areapath testsuite mtexe run-id) ;; run on main.db server (rmt:send-receive 'start-server #f (list areapath testsuite mtexe run-id))) ;;====================================================================== ;; M I S C ;;====================================================================== (define (rmt:login run-id) (rmt:send-receive 'login run-id (list *toppath* megatest-version (client:get-signature)))) ;; This login does no retries under the hood - it acts a bit like a ping. ;; Deprecated for nmsg-transport. ;; ;; (define (rmt:login-no-auto-client-setup runremote) ;; (rmt:send-receive-no-auto-client-setup runremote 'login #f (list *toppath* megatest-version (client:get-signature)))) ;; given a hostname, return a pair of cpu load and update time representing latest intelligence from tests running on that host (define (rmt:get-latest-host-load hostname) (rmt:send-receive 'get-latest-host-load #f (list hostname))) (define (rmt:sdb-qry qry val run-id) ;; add caching if qry is 'getid or 'getstr (rmt:send-receive 'sdb-qry run-id (list qry val))) ;; NOT COMPLETED (define (rmt:runtests user run-id testpatt params) (rmt:send-receive 'runtests run-id testpatt)) (define (rmt:get-run-record-ids target run keynames ) (rmt:send-receive 'get-run-record-ids #f (list target run keynames ))) (define (rmt:get-changed-record-ids since-time) (rmt:send-receive 'get-changed-record-ids #f (list since-time)) ) (define (rmt:get-all-runids) (rmt:send-receive 'get-all-run-ids #f '()) ) (define (rmt:get-changed-record-run-ids since-time) (rmt:send-receive 'get-changed-record-run-ids #f (list since-time))) (define (rmt:get-changed-record-test-ids run-id since-time) (rmt:send-receive 'get-changed-record-test-ids run-id (list since-time run-id))) (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 '())) ;;====================================================================== ;; K E Y S ;;====================================================================== ;; These require run-id because the values come from the run! ;; however the query must still apply to main.db ;; (define (rmt:get-key-val-pairs run-id) (rmt:send-receive 'get-key-val-pairs #f (list run-id))) (define (rmt:get-keys) (if *db-keys* *db-keys* (let ((res (rmt:send-receive 'get-keys #f '()))) (set! *db-keys* res) res))) |
︙ | ︙ | |||
529 530 531 532 533 534 535 | (hash-table-set! *keyvals* run-id res) res))) (define (rmt:get-targets) (rmt:send-receive 'get-targets #f '())) (define (rmt:get-target run-id) | > | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 | (hash-table-set! *keyvals* run-id res) res))) (define (rmt:get-targets) (rmt:send-receive 'get-targets #f '())) (define (rmt:get-target run-id) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-target #f (list run-id))) (define (rmt:get-run-times runpatt targetpatt) (rmt:send-receive 'get-run-times #f (list runpatt targetpatt ))) ;;====================================================================== ;; T E S T S ;;====================================================================== ;; IDEA: Threadify these - they spend a lot of time waiting ... ;; (define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in) (let ((multi-run-mutex (make-mutex)) (run-id-list (if run-ids run-ids (rmt:get-all-run-ids))) |
︙ | ︙ | |||
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 | ;; run-ids ;; (rmt:get-all-run-ids)))) ;; (apply append (map (lambda (run-id) ;; (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-ids testpatt states status not-in))) ;; run-id-list)))) (define (rmt:delete-test-records run-id test-id) (rmt:send-receive 'delete-test-records run-id (list run-id test-id))) (define (rmt:test-set-state-status run-id test-id state status msg) (rmt:send-receive 'test-set-state-status run-id (list run-id test-id state status msg))) (define (rmt:test-toplevel-num-items run-id test-name) (rmt:send-receive 'test-toplevel-num-items run-id (list run-id test-name))) ;; (define (rmt:get-previous-test-run-record run-id test-name item-path) ;; (rmt:send-receive 'get-previous-test-run-record run-id (list run-id test-name item-path))) (define (rmt:get-matching-previous-test-run-records run-id test-name item-path) (rmt:send-receive 'get-matching-previous-test-run-records run-id (list run-id test-name item-path))) (define (rmt:test-get-logfile-info run-id test-name) (rmt:send-receive 'test-get-logfile-info run-id (list run-id test-name))) (define (rmt:test-get-records-for-index-file run-id test-name) (rmt:send-receive 'test-get-records-for-index-file run-id (list run-id test-name))) (define (rmt:get-testinfo-state-status run-id test-id) (rmt:send-receive 'get-testinfo-state-status run-id (list run-id test-id))) (define (rmt:test-set-log! run-id test-id logf) (if (string? logf)(rmt:general-call 'test-set-log run-id logf test-id))) (define (rmt:test-set-top-process-pid run-id test-id pid) (rmt:send-receive 'test-set-top-process-pid run-id (list run-id test-id pid))) (define (rmt:test-get-top-process-pid run-id test-id) (rmt:send-receive 'test-get-top-process-pid run-id (list run-id test-id))) (define (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt) (rmt:send-receive 'get-run-ids-matching-target #f (list keynames target res runname testpatt statepatt statuspatt))) ;; NOTE: This will open and access ALL run databases. ;; (define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname) (let ((run-ids (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt))) (apply append (map (lambda (run-id) (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname))) run-ids)))) (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) | > > > > > > > > > > > > > | | < > > > > < < | < | < > > > > > > | > | | | | > > > > > > > > > > > > | 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 | ;; run-ids ;; (rmt:get-all-run-ids)))) ;; (apply append (map (lambda (run-id) ;; (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-ids testpatt states status not-in))) ;; run-id-list)))) (define (rmt:delete-test-records run-id test-id) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'delete-test-records run-id (list run-id test-id))) (define (rmt:test-set-state-status run-id test-id state status msg) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'test-set-state-status run-id (list run-id test-id state status msg))) (define (rmt:test-toplevel-num-items run-id test-name) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'test-toplevel-num-items run-id (list run-id test-name))) ;; (define (rmt:get-previous-test-run-record run-id test-name item-path) ;; (rmt:send-receive 'get-previous-test-run-record run-id (list run-id test-name item-path))) (define (rmt:get-matching-previous-test-run-records run-id test-name item-path) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-matching-previous-test-run-records run-id (list run-id test-name item-path))) (define (rmt:test-get-logfile-info run-id test-name) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'test-get-logfile-info run-id (list run-id test-name))) (define (rmt:test-get-records-for-index-file run-id test-name) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'test-get-records-for-index-file run-id (list run-id test-name))) (define (rmt:get-testinfo-state-status run-id test-id) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-testinfo-state-status run-id (list run-id test-id))) (define (rmt:test-set-log! run-id test-id logf) (assert (number? run-id) "FATAL: Run id required.") (if (string? logf)(rmt:general-call 'test-set-log run-id logf test-id))) (define (rmt:test-set-top-process-pid run-id test-id pid) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'test-set-top-process-pid run-id (list run-id test-id pid))) (define (rmt:test-get-top-process-pid run-id test-id) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'test-get-top-process-pid run-id (list run-id test-id))) (define (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt) (rmt:send-receive 'get-run-ids-matching-target #f (list keynames target res runname testpatt statepatt statuspatt))) ;; NOTE: This will open and access ALL run databases. ;; (define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname) (let ((run-ids (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt))) (apply append (map (lambda (run-id) (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname))) run-ids)))) (define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f)) (assert (number? run-id) "FATAL: Run id required.") (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) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id))) (define (rmt:get-not-completed-cnt run-id) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-not-completed-cnt run-id (list run-id))) ;; Statistical queries (define (rmt:get-count-tests-running run-id) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-count-tests-running run-id (list run-id))) (define (rmt:get-count-tests-running-for-testname run-id testname) (assert (number? run-id) "FATAL: Run id required.") (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) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup))) (define (rmt:set-state-status-and-roll-up-run run-id state status) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'set-state-status-and-roll-up-run run-id (list run-id state status))) (define (rmt:update-pass-fail-counts run-id test-name) (assert (number? run-id) "FATAL: Run id required.") (rmt:general-call 'update-pass-fail-counts run-id test-name test-name test-name)) (define (rmt:top-test-set-per-pf-counts run-id test-name) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'top-test-set-per-pf-counts run-id (list run-id test-name))) (define (rmt:get-raw-run-stats run-id) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-raw-run-stats run-id (list run-id))) (define (rmt:get-test-times runname target) (rmt:send-receive 'get-test-times #f (list runname target ))) ;;====================================================================== ;; R U N S ;;====================================================================== ;; BUG - LOOK AT HOW THIS WORKS!!! ;; (define (rmt:get-run-info run-id) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-run-info #f (list run-id))) (define (rmt:get-num-runs runpatt) (rmt:send-receive 'get-num-runs #f (list runpatt))) (define (rmt:get-runs-cnt-by-patt runpatt targetpatt keys) (rmt:send-receive 'get-runs-cnt-by-patt #f (list runpatt targetpatt keys))) ;; Use the special run-id == #f scenario here since there is no run yet (define (rmt:register-run keyvals runname state status user contour) (rmt:send-receive 'register-run #f (list keyvals runname state status user contour))) (define (rmt:get-run-name-from-id run-id) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-run-name-from-id #f (list run-id))) (define (rmt:delete-run run-id) (rmt:send-receive 'delete-run #f (list run-id))) (define (rmt:update-run-stats run-id stats) (rmt:send-receive 'update-run-stats #f (list run-id stats))) (define (rmt:delete-old-deleted-test-records run-id) (rmt:send-receive 'delete-old-deleted-test-records run-id (list run-id))) (define (rmt:get-runs runpatt count offset keypatts) (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts))) (define (rmt:simple-get-runs runpatt count offset target last-update) (rmt:send-receive 'simple-get-runs #f (list runpatt count offset target last-update))) (define (rmt:get-all-run-ids) (rmt:send-receive 'get-all-run-ids #f '())) (define (rmt:get-prev-run-ids run-id) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-prev-run-ids #f (list run-id))) (define (rmt:lock/unlock-run run-id lock unlock user) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'lock/unlock-run #f (list run-id lock unlock user))) ;; set/get status (define (rmt:get-run-status run-id) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-run-status #f (list run-id))) (define (rmt:get-run-state run-id) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-run-state #f (list run-id))) (define (rmt:get-run-state-status run-id) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-run-state-status #f (list run-id))) (define (rmt:set-run-status run-id run-status #!key (msg #f)) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'set-run-status #f (list run-id run-status msg))) (define (rmt:set-run-state-status run-id state status ) (assert (number? run-id) "FATAL: Run id required.") (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) (assert (number? run-id) "FATAL: Run id required.") (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))) (define (rmt:find-and-mark-incomplete run-id ovr-deadtime) (assert (number? run-id) "FATAL: Run id required.") ;; (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime)) (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime))) ;; ) (define (rmt:get-main-run-stats run-id) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-main-run-stats #f (list run-id))) (define (rmt:get-var varname) (rmt:send-receive 'get-var #f (list varname))) (define (rmt:del-var varname) (rmt:send-receive 'del-var #f (list varname))) |
︙ | ︙ | |||
892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 | ;; 1. Do a remote call to get the test path ;; 2. Continue as above ;; ;;(define (rmt:get-steps-for-test run-id test-id) ;; (rmt:send-receive 'get-steps-data run-id (list test-id))) (define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile) (let* ((state (items:check-valid-items "state" state-in)) (status (items:check-valid-items "status" status-in))) (if (or (not state)(not status)) (debug:print 3 *default-log-port* "WARNING: Invalid " (if status "status" "state") " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile)))) (define (rmt:delete-steps-for-test! run-id test-id) (rmt:send-receive 'delete-steps-for-test! run-id (list run-id test-id))) (define (rmt:get-steps-for-test run-id test-id) (rmt:send-receive 'get-steps-for-test run-id (list run-id test-id))) | > > > | > | > > | > | | > | > > | 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 | ;; 1. Do a remote call to get the test path ;; 2. Continue as above ;; ;;(define (rmt:get-steps-for-test run-id test-id) ;; (rmt:send-receive 'get-steps-data run-id (list test-id))) (define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile) (assert (number? run-id) "FATAL: Run id required.") (let* ((state (items:check-valid-items "state" state-in)) (status (items:check-valid-items "status" status-in))) (if (or (not state)(not status)) (debug:print 3 *default-log-port* "WARNING: Invalid " (if status "status" "state") " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile)))) (define (rmt:delete-steps-for-test! run-id test-id) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'delete-steps-for-test! run-id (list run-id test-id))) (define (rmt:get-steps-for-test run-id test-id) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-steps-for-test run-id (list run-id test-id))) (define (rmt:get-steps-info-by-id run-id test-step-id) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-steps-info-by-id #f (list run-id test-step-id))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== (define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'read-test-data run-id (list run-id test-id categorypatt))) (define (rmt:read-test-data-varpatt run-id test-id categorypatt varpatt #!key (work-area #f)) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'read-test-data-varpatt run-id (list run-id test-id categorypatt varpatt))) (define (rmt:get-data-info-by-id run-id test-data-id) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-data-info-by-id #f (list run-id test-data-id))) (define (rmt:testmeta-add-record testname) (rmt:send-receive 'testmeta-add-record #f (list testname))) (define (rmt:testmeta-get-record testname) (rmt:send-receive 'testmeta-get-record #f (list testname))) (define (rmt:testmeta-update-field test-name fld val) (rmt:send-receive 'testmeta-update-field #f (list test-name fld val))) (define (rmt:test-data-rollup run-id test-id status) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'test-data-rollup run-id (list run-id test-id status))) (define (rmt:csv->test-data run-id test-id csvdata) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'csv->test-data run-id (list run-id test-id csvdata))) ;;====================================================================== ;; T A S K S ;;====================================================================== (define (rmt:tasks-find-task-queue-records target run-name test-patt state-patt action-patt) |
︙ | ︙ | |||
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 | (define (rmt:no-sync-take-job host-type) (rmt:send-receive 'no-sync-take-job #f `(,host-type))) (define (rmt:no-sync-job-records-clean) (rmt:set-receive 'no-sync-job-records-clean #f '())) ;;====================================================================== ;; A R C H I V E S ;;====================================================================== (define (rmt:archive-get-allocations testname itempath dneeded) (rmt:send-receive 'archive-get-allocations #f (list testname itempath dneeded))) (define (rmt:archive-register-block-name bdisk-id archive-path) (rmt:send-receive 'archive-register-block-name #f (list bdisk-id archive-path))) (define (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey) (rmt:send-receive 'archive-allocate-test-to-block #f (list block-id testsuite-name areakey))) (define (rmt:archive-register-disk bdisk-name bdisk-path df) (rmt:send-receive 'archive-register-disk #f (list bdisk-name bdisk-path df))) (define (rmt:test-set-archive-block-id run-id test-id archive-block-id) (rmt:send-receive 'test-set-archive-block-id run-id (list run-id test-id archive-block-id))) (define (rmt:test-get-archive-block-info archive-block-id) (rmt:send-receive 'test-get-archive-block-info #f (list archive-block-id))) | > > > > > > > > > > > > > > > < > > | | | | | | | | | | | | < | < < < | | < < > > | > | | | < < | < < < < < < < < | | | | | | | | | | | < < < < < < < < < < < > | < < | 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 | (define (rmt:no-sync-take-job host-type) (rmt:send-receive 'no-sync-take-job #f `(,host-type))) (define (rmt:no-sync-job-records-clean) (rmt:set-receive 'no-sync-job-records-clean #f '())) ;; process registration (define (rmt:register-process host port pid starttime status purpose dbname mtversion) (rmt:send-receive 'register-process #f (list host port pid starttime status purpose dbname mtversion))) (define (rmt:set-process-done host pid reason) (rmt:send-receive 'set-process-done #f (list host pid reason))) (define (rmt:set-process-status host pid newstatus) (rmt:send-receive 'set-process-status #f (list host pid newstatus))) (define (rmt:get-process-options purpose dbname) (rmt:get-process-options 'get-process-options #f (list purpose dbname))) ;;====================================================================== ;; A R C H I V E S ;;====================================================================== (define (rmt:archive-get-allocations testname itempath dneeded) (rmt:send-receive 'archive-get-allocations #f (list testname itempath dneeded))) (define (rmt:archive-register-block-name bdisk-id archive-path) (rmt:send-receive 'archive-register-block-name #f (list bdisk-id archive-path))) (define (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey) (rmt:send-receive 'archive-allocate-test-to-block #f (list block-id testsuite-name areakey))) (define (rmt:archive-register-disk bdisk-name bdisk-path df) (rmt:send-receive 'archive-register-disk #f (list bdisk-name bdisk-path df))) (define (rmt:test-set-archive-block-id run-id test-id archive-block-id) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'test-set-archive-block-id run-id (list run-id test-id archive-block-id))) (define (rmt:test-get-archive-block-info archive-block-id) (rmt:send-receive 'test-get-archive-block-info #f (list archive-block-id))) (define (rmtmod:calc-ro-mode runremote *toppath*) (case (rmt:transport-mode) ((http) (if (and runremote (remote-ro-mode-checked runremote)) (remote-ro-mode runremote) (let* ((mtcfgfile (conc *toppath* "/megatest.config")) (ro-mode (not (file-write-access? mtcfgfile)))) ;; TODO: use dbstruct or runremote to figure this out in future (if runremote (begin (remote-ro-mode-set! runremote ro-mode) (remote-ro-mode-checked-set! runremote #t) ro-mode) ro-mode)))) ((tcp) (if (and runremote (tt-ro-mode-checked runremote)) (tt-ro-mode runremote) (let* ((mtcfgfile (conc *toppath* "/megatest.config")) (ro-mode (not (file-write-access? mtcfgfile)))) ;; TODO: use dbstruct or runremote to figure this out in future (if runremote (begin (tt-ro-mode-set! runremote ro-mode) (tt-ro-mode-checked-set! runremote #t) ro-mode) ro-mode)))))) ;;====================================================================== ;; Maintenance ;;====================================================================== (define (rmt:find-and-mark-incomplete run-id ovr-deadtime) (let* ((cfg-deadtime (configf:lookup-number *configdat* "setup" "deadtime")) (test-stats-update-period (configf:lookup-number *configdat* "setup" "test-stats-update-period"))) (rmt:find-and-mark-incomplete-engine run-id ovr-deadtime cfg-deadtime test-stats-update-period) ;;call end of eud of run detection for posthook (launch:end-of-run-check run-id))) ;; orphaned from cherrypick merge ;; (debug:print 0 *default-log-port* "Inserting " (length tests-data) " tests in run " runname) |
Modified rmtmod.scm from [6b720dfd33] to [1cfe9c07c7].
︙ | ︙ | |||
15 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 rmtmod)) (declare (uses commonmod)) | > > > > > > > > | | | > | > > > | | > > | | | > > > | > > > > | | | > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > | | > > > > > > > > > > > > > | > > > | > > > > | > > > | > > > > > > > | > > | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > | < > > > > > > | | < < | < < < < < | < < < > > > > > > > > > > > > | > > | > > > > | > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;; ;; 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 debugprint)) ;; (declare (uses debugprint.import)) (declare (uses commonmod)) ;; (declare (uses commonmod.import)) (declare (uses dbfile)) ;; needed for records (declare (uses dbmod)) ;; (declare (uses tcp-transportmod)) ;; (declare (uses tcp-transportmod.import)) ;; (declare (uses apimod)) ;; (declare (uses apimod.import)) ;; (declare (uses ulex)) ;; (include "ulex/ulex.scm") (module rmtmod * (import scheme chicken data-structures extras matchable srfi-69) (import (prefix sqlite3 sqlite3:) posix typed-records srfi-18) (import commonmod dbfile debugprint) ;; (prefix commonmod cmod:)) (import dbmod ;; tcp-transportmod ) ;; (import apimod) ;; (import (prefix ulex ulex:)) (include "db_records.scm") (defstruct alldat (areapath #f) (ulexdat #f) ) ;; hold the send-receive proc in this parameter (define rmtmod:send-receive #f) ;; (make-parameter #f)) ;;====================================================================== ;; M I S C ;;====================================================================== ;; hand off a call to one of the db:queries statements ;; added run-id to make looking up the correct db possible ;; (define (rmt:general-call stmtname run-id . params) (rmtmod:send-receive 'general-call run-id (append (list stmtname run-id) params))) ;;====================================================================== ;; import an sexpr file into the db ;;====================================================================== (define (rmt:import-sexpr sexpr-file) (if (file-exists? sexpr-file) (let* ((data (with-input-from-file sexpr-file read))) (for-each (lambda (targ-dat) (rmt:import-target targ-dat)) ;; ("target" ("run1" ("data" (1 ("field" . "value") ... data)) (let* ((msg (conc "ERROR: file "sexpr-file" not found"))) (debug:print 0 *default-log-port* msg) (cons #f msg)))) (define (rmt:import-target targ-dat) (let* ((target (car targ-dat)) (data (cdr targ-dat))) (for-each (lambda (run-dat) (rmt:import-run target run-dat)) ;; ("runname" ("data" ("testid" ("field" . "value") ... data))) (define (rmt:import-run target run-dat) (let* ((runname (car run-dat)) (all-dat (cdr run-dat)) (tests-data (alist-ref "data" all-dat equal?)) (run-meta (alist-ref "meta" all-dat equal?)) (run-id (string->number (alist-ref "id" run-meta equal?)))) (rmt:insert-run run-id target runname run-meta) (if (list? tests-data) (begin (debug:print 0 *default-log-port* "import-run: inserting " (length tests-data) " tests") (for-each (lambda (test-dat) (let* ((test-id (car test-dat)) (test-rec (cdr test-dat))) (rmt:insert-test run-id test-rec))) tests-data) ) (debug:print 0 *default-log-port* "import-run: run has no tests") ) ) ) ;; insert run if not there, return id either way (define (rmt:insert-run run-id target runname run-meta) ;; look for id, return if found (let* ((runs (rmtmod:send-receive 'simple-get-runs #f ;; runpatt count offset target last-update) (list runname #f #f target #f)))) (if (null? runs) (begin (debug:print 0 *default-log-port* "inserting run for runname " runname " target " target) (rmtmod:send-receive 'insert-run #f (list run-id target runname run-meta)) ) (begin (debug:print 0 *default-log-port* "Found run-id " (simple-run-id (car runs)) " for runname " runname " target " target) (simple-run-id (car runs)) )))) (define (rmt:insert-test run-id test-rec) (let* ((testname (alist-ref "testname" test-rec equal?)) (item-path (alist-ref "item_path" test-rec equal?)) (test-id (rmt:get-test-id run-id testname item-path)) ) (if test-id (debug:print 0 *default-log-port* "test "testname"/"item-path " already exists in run-id " run-id) (begin (debug:print 0 *default-log-port* " Insert test in run "run-id": "testname"/"item-path) (rmtmod:send-receive 'insert-test run-id test-rec) ) ) ) ) ;;====================================================================== ;; T E S T S ;;====================================================================== ;; Just some syntatic sugar (define (rmt:register-test run-id test-name item-path) (assert (number? run-id) "FATAL: Run id required.") (rmt:general-call 'register-test run-id run-id test-name item-path)) (define (rmt:get-test-id run-id testname item-path) (assert (number? run-id) "FATAL: Run id required.") (rmtmod:send-receive 'get-test-id run-id (list run-id testname item-path))) (define (rmt:get-test-info-by-id run-id test-id) (if (number? test-id) (rmtmod:send-receive 'get-test-info-by-id run-id (list run-id test-id)) (begin (debug:print 0 *default-log-port* "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id) (print-call-chain (current-error-port)) #f))) (define (rmt:get-test-state-status-by-id run-id test-id) (rmtmod:send-receive 'get-test-state-status-by-id run-id (list run-id test-id))) (define (rmt:test-get-rundir-from-test-id run-id test-id) (rmtmod:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id))) ;; (define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f)) ;; (assert (number? run-id) "FATAL: Run id required.") ;; (let* ((test-path (if (string? work-area) ;; work-area ;; (rmt:test-get-rundir-from-test-id run-id test-id)))) ;; (debug:print 3 *default-log-port* "TEST PATH: " test-path) ;; (open-test-db test-path))) ;; WARNING: This currently bypasses the transaction wrapped writes system (define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) (assert (number? run-id) "FATAL: Run id required.") (rmtmod:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment))) (define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus) (assert (number? run-id) "FATAL: Run id required.") (rmtmod:send-receive 'set-tests-state-status run-id (list run-id testnames currstate currstatus newstate newstatus))) (define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) (assert (number? run-id) "FATAL: Run id required.") ;; (if (number? run-id) (rmtmod:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode))) ;; (begin ;; (debug:print-error 0 *default-log-port* "rmt:get-tests-for-run called with bad run-id=" run-id) ;; (print-call-chain (current-error-port)) ;; '()))) (define (rmt:get-tests-for-run-state-status run-id testpatt last-update) (assert (number? run-id) "FATAL: Run id required.") (rmtmod:send-receive 'get-tests-for-run-state-status run-id (list run-id testpatt last-update))) ;; get stuff via synchash (define (rmt:synchash-get run-id proc synckey keynum params) (assert (number? run-id) "FATAL: Run id required.") (rmtmod:send-receive 'synchash-get run-id (list run-id proc synckey keynum params))) (define (rmt:get-tests-for-run-mindata run-id testpatt states status not-in) (assert (number? run-id) "FATAL: Run id required.") (rmtmod:send-receive 'get-tests-for-run-mindata run-id (list run-id testpatt states status not-in))) ;; state and status are extra hints not usually used in the calculation ;; (define (rmt:set-state-status-and-roll-up-items run-id test-name item-path state status comment) (assert (number? run-id) "FATAL: Run id required.") (rmtmod:send-receive 'set-state-status-and-roll-up-items run-id (list run-id test-name item-path state status comment))) ;;====================================================================== ;; Maintenance ;;====================================================================== (define (rmt:get-toplevels-and-incompletes run-id running-deadtime remotehoststart-deadtime) (rmtmod:send-receive 'get-toplevels-and-incompletes run-id (list run-id running-deadtime remotehoststart-deadtime))) (define (rmt: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 2 *default-log-port* "ERROR: cannot read " infile) (debug:print 2 *default-log-port* "ERROR: run-dir is " run-dir) #f ) (let ((res (with-input-from-file infile read-lines))) (if (null? res) #f (string-split (car res))))))) ;; 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')); ;; ;; NOT EASY TO MIGRATE TO db{file,mod} ;; (define (rmt:find-and-mark-incomplete-engine run-id ovr-deadtime cfg-deadtime test-stats-update-period) (let* ((incompleted '()) (oldlaunched '()) (toplevels '()) ;; The default running-deadtime is 720 seconds = 12 minutes. ;; "(running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period)))" = 200 + (2 * (200 + 30 + 30)) (deadtime-trim (or ovr-deadtime cfg-deadtime)) (server-start-allowance 200) (server-overloaded-budget 200) (launch-monitor-off-time (or test-stats-update-period 30)) (launch-monitor-on-time-budget 30) (launch-monitor-period (+ launch-monitor-off-time launch-monitor-on-time-budget server-overloaded-budget)) (remotehoststart-deadtime-default (+ server-start-allowance server-overloaded-budget 30)) (remotehoststart-deadtime (or deadtime-trim remotehoststart-deadtime-default)) (running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period))) (running-deadtime (or deadtime-trim running-deadtime-default))) ;; two minutes (30 seconds between updates, this leaves 3x grace period) (debug:print-info 4 *default-log-port* "running-deadtime = " running-deadtime) (debug:print-info 4 *default-log-port* "deadtime-trim = " deadtime-trim) (let* ((dat (rmt:get-toplevels-and-incompletes run-id running-deadtime remotehoststart-deadtime))) (set! oldlaunched (list-ref dat 1)) (set! toplevels (list-ref dat 2)) (set! incompleted (list-ref dat 0))) (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.") ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE. ;; ;; (db:delay-if-busy dbdat) (let* ((min-incompleted-ids (map car incompleted)) ;; do 'em all (all-ids (append min-incompleted-ids (map car oldlaunched)))) (if (> (length all-ids) 0) (begin ;; (launch:is-test-alive "localhost" 435) (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as DEAD") (for-each (lambda (test-id) (let* ((tinfo (rmt:get-test-info-by-id run-id test-id)) (run-dir (db:test-get-rundir tinfo)) (host (db:test-get-host tinfo)) (pid (db:test-get-process_id tinfo)) (result (rmt:get-status-from-final-status-file run-dir))) (if (and (list? result) (> (length result) 1) (equal? "PASS" (cadr result)) (equal? "COMPLETED" (car result))) (begin (debug:print 0 *default-log-port* "INFO: test " test-id " actually passed, so marking PASS not DEAD") (rmt:set-state-status-and-roll-up-items run-id test-id 'foo "COMPLETED" "PASS" "Test stopped responding but it has PASSED; marking it PASS in the DB.")) (let ((is-alive (and (not (eq? pid 0)) ;; 0 is default in re-used field "attemptnum" where pid stored. (commonmod: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) (rmt:set-state-status-and-roll-up-items 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) ))))) ;;====================================================================== ;; Misc ;;====================================================================== ;; (define (rmtmod:wait-on-server-load run-id ttdat) ;; (let* ((dbfname (dbmod:run-id->dbfname run-id)) ;; (get-lowest-thread-load ;; (lambda () ;; (let* ((sdats (tt:get-server-info-sorted ttdat dbfname))) ;; (car (map tt:get-server-threads sdats)))))) ;; (if ttdat ;; (let loop () ;; (if (> (get-lowest-thread-load) 5) ;; load is pretty high ;; (begin ;; (debug:print 0 *default-log-port* "Servers appear overloaded, waiting...") ;; (thread-sleep! 1) ;; (loop)))) ;; (debug:print 0 *default-log-port* "Can't wait on server load, *ttdat* not set")))) ) |
Modified runconfig.scm from [66b9c38588] to [e745c7478e].
︙ | ︙ | |||
20 21 22 23 24 25 26 27 28 29 30 31 32 33 | ;; to this run field1val/field2val/field3val ... ;;====================================================================== (use format directory-utils) (declare (unit runconfig)) (declare (uses common)) (include "common_records.scm") (define (runconfig:read fname target environ-patt) (let ((ht (make-hash-table))) (if target (hash-table-set! ht target '())) (read-config fname ht #t environ-patt: environ-patt sections: (if target (list "default" target) #f)))) | > > > > > | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | ;; to this run field1val/field2val/field3val ... ;;====================================================================== (use format directory-utils) (declare (unit runconfig)) (declare (uses common)) (declare (uses debugprint)) (declare (uses commonmod)) (import commonmod debugprint) (include "common_records.scm") (define (runconfig:read fname target environ-patt) (let ((ht (make-hash-table))) (if target (hash-table-set! ht target '())) (read-config fname ht #t environ-patt: environ-patt sections: (if target (list "default" target) #f)))) |
︙ | ︙ |
Modified runs.scm from [10c892ad0a] to [66eb6eaf19].
︙ | ︙ | |||
13 14 15 16 17 18 19 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') | < < < < > > | > > > > > > > > > > > > > > > > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 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 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') (declare (unit runs)) (declare (uses db)) (declare (uses common)) (declare (uses debugprint)) (declare (uses commonmod)) (declare (uses items)) (declare (uses runconfig)) (declare (uses tests)) (declare (uses server)) (declare (uses mt)) (declare (uses archive)) (declare (uses mtargs)) (declare (uses rmtmod)) (declare (uses dbfile)) (declare (uses tcp-transportmod)) (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) posix-extras directory-utils pathname-expand typed-records format sxml-serializer sxml-modifications matchable) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") ;; (include "debugger.scm") (import commonmod debugprint rmtmod dbfile tcp-transportmod (prefix mtargs args:)) ;; use this struct to facilitate refactoring ;; (defstruct runs:dat reglen regfull runname max-concurrent-jobs run-id test-patts required-tests test-registry |
︙ | ︙ | |||
59 60 61 62 63 64 65 | (last-jobs-check-time 0) ) (defstruct runs:testdat hed tal reg reruns test-record test-name item-path jobgroup waitons testmode newtal itemmaps prereqs-not-met) | | < < < < < < < < < < < < < < < < < < < < < < < < < < < | 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 | (last-jobs-check-time 0) ) (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 |
︙ | ︙ | |||
125 126 127 128 129 130 131 | (if (runs:lownoise "runners-softlock-wait" 360) (debug:print-info 0 *default-log-port* "Other runners in flight, giving up some time...")) (thread-sleep! 2)) (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))) | | < | | 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 | (if (runs:lownoise "runners-softlock-wait" 360) (debug:print-info 0 *default-log-port* "Other runners in flight, giving up some time...")) (thread-sleep! 2)) (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")))) |
︙ | ︙ | |||
253 254 255 256 257 258 259 | (launch:setup force-reread: #t) (fatal-loop (+ count 1))) (begin (debug:print 0 *default-log-port* "FATAL: *configdat* was inaccessible! This should never happen. Retried " count " times. Message: " msg) (debug:print 0 *default-log-port* "Call chain:") (with-output-to-port *default-log-port* | < | | | 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 | (launch:setup force-reread: #t) (fatal-loop (+ count 1))) (begin (debug:print 0 *default-log-port* "FATAL: *configdat* was inaccessible! This should never happen. Retried " count " times. Message: " msg) (debug:print 0 *default-log-port* "Call chain:") (with-output-to-port *default-log-port* (lambda () (print "*configdat* is >>"*configdat*"<<") (pp *configdat*) (pp call-chain))) (exit 1)))) ;;(bb-check-path msg: "runs:set-megatest-env-vars block 1.5") (when (or (not *configdat*) (not (hash-table? *configdat*))) (debug:print 0 *default-log-port* "WARNING: *configdat* was inaccessible! This should never happen. Brute force reread.") |
︙ | ︙ | |||
337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 | (currtime (current-seconds))) (if (> (- currtime lasttime) waitval) (begin (hash-table-set! *runs:denoise* key currtime) #t) #f))) (define (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs) ;; Take advantage of a good place to exit if running the one-pass methodology (if (and (> (runs:dat-can-run-more-tests-count runsdat) 20) (args:get-arg "-one-pass")) (exit 0)) (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat))) | > > > > > > > > > > > > > > > | | | | > | | 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 | (currtime (current-seconds))) (if (> (- currtime lasttime) waitval) (begin (hash-table-set! *runs:denoise* key currtime) #t) #f))) (define *last-test-launch* 0) (define *too-soon-delays* (make-hash-table)) ;; to-soon delay, when matching event happened in less than dseconds delay wseconds ;; (define (runs:too-soon-delay key dseconds wseconds) (let* ((last-time (hash-table-ref/default *too-soon-delays* key #f))) (if (and last-time (< (- (current-seconds) last-time) dseconds)) (begin (if (runs:lownoise (conc "too-soon-delay"key) 60) (debug:print-info 2 *default-log-port* "Polling throttle for "key)) (thread-sleep! wseconds))) (hash-table-set! *too-soon-delays* key (current-seconds)))) (define (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs) ;; Take advantage of a good place to exit if running the one-pass methodology (if (and (> (runs:dat-can-run-more-tests-count runsdat) 20) (args:get-arg "-one-pass")) (exit 0)) (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat))) (let* ((num-running (rmt:get-count-tests-running-for-run-id run-id)) (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))) (if (not (eq? *last-num-running-tests* num-running)) (begin (debug:print 2 *default-log-port* "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) (set! *last-num-running-tests* num-running))) (if (not (eq? 0 *globalexitstatus*)) (list #f num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit) |
︙ | ︙ | |||
517 518 519 520 521 522 523 | ;; return #t when all items in waitors-upon list are represented in test-patt, #f otherwise. (define (runs:testpatts-mention-waitors-upon? test-patt waitors-upon) (null? (tests:filter-test-names-not-matched waitors-upon test-patt))) | < < > | | | < < | | | | 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 | ;; return #t when all items in waitors-upon list are represented in test-patt, #f otherwise. (define (runs:testpatts-mention-waitors-upon? test-patt waitors-upon) (null? (tests:filter-test-names-not-matched waitors-upon test-patt))) ;;====================================================================== ;; runs:run-tests is called from megatest.scm and itself ;;====================================================================== ;; ;; test-names: Comma separated patterns same as test-patts but used in selection ;; of tests to run. The item portions are not respected. ;; FIXME: error out if /patt specified ;; ;; run-count is passed from megatest.scm as configf:lookup *configdat* "setup" "reruns", or defaults to 1. (define (runs:run-tests target runname test-patts user flags #!key (run-count 1)) ;; test-names (let* ((keys (keys:config-get-fields *configdat*)) (keyvals (keys:target->keyval keys target)) (run-id (rmt:register-run keyvals runname "new" "n/a" user (args:get-arg "-contour"))) ;; test-name))) ;; (deferred '()) ;; delay running these since they have a waiton clause (runconfigf (conc *toppath* "/runconfigs.config")) (mtconfig (conc *toppath* "/megatest.config")) (readonly-mode (not (file-write-access? mtconfig))) (test-records (make-hash-table)) ;; need to process runconfigs before generating these lists (all-tests-registry #f) ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names (all-test-names #f) ;; (hash-table-keys all-tests-registry)) (test-names #f) ;; Generated by a call to (tests:filter-test-names all-test-names test-patts)) (required-tests #f) ;; Put fully qualified test/testpath names in this list to be done (waitors-upon (make-hash-table)) ;; given a test, return list of tests waiting upon this test. (task-key (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id))) ;; (tdbdat (tasks:open-db)) (config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns"))) (if x (string->number x) #f))) (allowed-tests #f) (runconf #f)) ;; check if readonly (when readonly-mode (debug:print-error 0 *default-log-port* "Megatest database is readonly. Cannot proceed.") (exit 1)) ;; per user request. If less than 100Meg space on dbdir partition, bail out with error ;; this will reduce issues in database corruption (common:check-db-dir-and-exit-if-insufficient) ;; override the number of reruns from the configs ;; this needs to be done at the place where is first runs:run-tests called ;(if (and config-reruns ; (> run-count config-reruns)) ;(set! run-count config-reruns)) ;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) (let ((sighand (lambda (signum) ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting (set! *time-to-exit* #t) (debug:print 0 *default-log-port* "Received signal " signum ", cleaning up before exit. Please wait...") (let ((th1 (make-thread (lambda () ;; (let ((tdbdat (tasks:open-db))) (rmt:tasks-set-state-given-param-key task-key "killed") ;; ) (debug:print 0 *default-log-port* "Killed by signal " signum ". Exiting") (thread-sleep! 3) (exit)))) (th2 (make-thread (lambda () (thread-sleep! 5) (debug:print 0 *default-log-port* "Done") (exit 4))))) (thread-start! th2) |
︙ | ︙ | |||
652 653 654 655 656 657 658 | ;; (set! required-tests (lset-intersection equal? test-names all-test-names)) ;; look up all tests matching the comma separated list of globs in ;; test-patts (using % as wildcard) ;; (set! test-names (delete-duplicates (tests:get-valid-tests *toppath* test-patts))) (debug:print-info 0 *default-log-port* "tests search path: " (string-intersperse (tests:get-tests-search-path *configdat*) " ")) | | | 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 | ;; (set! required-tests (lset-intersection equal? test-names all-test-names)) ;; look up all tests matching the comma separated list of globs in ;; test-patts (using % as wildcard) ;; (set! test-names (delete-duplicates (tests:get-valid-tests *toppath* test-patts))) (debug:print-info 0 *default-log-port* "tests search path: " (string-intersperse (tests:get-tests-search-path *configdat*) " ")) (debug:print-info 2 *default-log-port* "all tests: " (string-intersperse (sort all-test-names string<) " ")) (debug:print-info 0 *default-log-port* "test names: " (string-intersperse (sort test-names string<) " ")) (debug:print-info 0 *default-log-port* "required tests: " (string-intersperse (sort required-tests string<) " ")) ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if ;; -keepgoing is specified (if (eq? *passnum* 0) (begin |
︙ | ︙ | |||
691 692 693 694 695 696 697 | ;; run the run prehook if there are no tests yet run for this run: ;; (runs:run-pre-hook run-id) ;; mark all test launched flag as false in the meta table (rmt:set-var (conc "lunch-complete-" run-id) "no") (debug:print-info 1 *default-log-port* "Setting end-of-run to no") (let* ((config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns"))) | | | | | | | | | | 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 | ;; run the run prehook if there are no tests yet run for this run: ;; (runs:run-pre-hook run-id) ;; mark all test launched flag as false in the meta table (rmt:set-var (conc "lunch-complete-" run-id) "no") (debug:print-info 1 *default-log-port* "Setting end-of-run to no") (let* ((config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns"))) (if x (string->number x) #f))) (config-rerun-cnt (if config-reruns config-reruns 1))) (if (eq? config-rerun-cnt run-count) (rmt:set-var (conc "end-of-run-" run-id) "no"))) (rmt:set-run-state-status run-id "new" "n/a") ;; now add non-directly referenced dependencies (i.e. waiton) ;;====================================================================== ;; refactoring this block into tests:get-full-data ;; ;; What happended, this code is now duplicated in tests!? ;; ;;====================================================================== (if (not (null? test-names)) ;; BEGIN test-names loop (let loop ((hed (car test-names)) ;; NOTE: This is the main loop that iterates over the test-names (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc (debug:print-info 4 *default-log-port* "\n\ntestpatt elaboration loop => hed="hed " tal="tal" test-patts="test-patts" test-names="test-names) (change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening. (setenv "MT_TEST_NAME" hed) ;; (let*-values (((waitons waitors config) (tests:get-waitons hed all-tests-registry (tests:get-global-waitons *runconfigdat*))) ;; NOTE: Have the config - can extract [waitons] section ((hed-mode) (let ((m (configf:lookup config "requirements" "mode"))) (if m (map string->symbol (string-split m)) '(normal)))) ((hed-itemized-waiton) ;; are items in hed waiting on items of waiton? |
︙ | ︙ | |||
766 767 768 769 770 771 772 | (waiton-record (hash-table-ref/default test-records waiton #f)) (waiton-tconfig (if waiton-record (vector-ref waiton-record 1) #f)) (waiton-itemized (and waiton-tconfig (or (hash-table-ref/default waiton-tconfig "items" #f) (hash-table-ref/default waiton-tconfig "itemstable" #f)))) (itemmaps (tests:get-itemmaps config)) ;; (configf:lookup config "requirements" "itemmap")) (new-test-patts (tests:extend-test-patts test-patts hed waiton itemmaps hed-itemized-waiton))) | | | 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 | (waiton-record (hash-table-ref/default test-records waiton #f)) (waiton-tconfig (if waiton-record (vector-ref waiton-record 1) #f)) (waiton-itemized (and waiton-tconfig (or (hash-table-ref/default waiton-tconfig "items" #f) (hash-table-ref/default waiton-tconfig "itemstable" #f)))) (itemmaps (tests:get-itemmaps config)) ;; (configf:lookup config "requirements" "itemmap")) (new-test-patts (tests:extend-test-patts test-patts hed waiton itemmaps hed-itemized-waiton))) (debug:print-info 2 *default-log-port* "Test " waiton " has " (if waiton-record "a" "no") " waiton-record and" (if waiton-itemized " " " no ") "items") ;; need to account for test-patt here, if I am test "a", selected with a test-patt of "hed/b%" ;; and we are waiting on "waiton" we need to add "waiton/,waiton/b%" to test-patt ;; is this satisfied by merely appending "/" to the waiton name added to the list? ;; ;; This approach causes all of the items in an upstream test to be run ;; if we have this waiton already processed once we can analzye it for extending ;; tests to be run, since we can't properly process waitons unless they have been |
︙ | ︙ | |||
788 789 790 791 792 793 794 | (set! test-names (cons waiton test-names)) ;; need to process this one, only add once the waiton tconfig read (set! required-tests (cons (conc waiton "/") required-tests)) (set! test-patts new-test-patts)) (begin (debug:print-info 0 *default-log-port* "Waitor(s) not yet on testpatt for " waiton ", setting up to re-process it") (set! tal (append (cons waiton tal)(list hed))))) (begin | | | 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 | (set! test-names (cons waiton test-names)) ;; need to process this one, only add once the waiton tconfig read (set! required-tests (cons (conc waiton "/") required-tests)) (set! test-patts new-test-patts)) (begin (debug:print-info 0 *default-log-port* "Waitor(s) not yet on testpatt for " waiton ", setting up to re-process it") (set! tal (append (cons waiton tal)(list hed))))) (begin (debug:print-info 2 *default-log-port* "Adding non-itemized test " waiton " to required-tests") (set! required-tests (cons waiton required-tests)) (set! test-patts new-test-patts))) (begin (debug:print-info 0 *default-log-port* "No testconfig info yet for " waiton ", setting up to re-process it") (set! tal (append (cons waiton tal)(list hed))))) ;; (cons (conc waiton "/") required-tests)) ;; NOPE: didn't work. required needs to be plain test names. Try tacking on to test-patts ;; - doesn't work |
︙ | ︙ | |||
813 814 815 816 817 818 819 | (if (not (null? required-tests)) (debug:print-info 1 *default-log-port* "Adding \"" (string-intersperse required-tests " ") "\" to the run queue")) ;; NOTE: these are all parent tests, items are not expanded yet. (debug:print-info 4 *default-log-port* "test-records=" (hash-table->alist test-records)) (let ((reglen (configf:lookup *configdat* "setup" "runqueue"))) (if (> (length (hash-table-keys test-records)) 0) | | < < < < < < < < < < < < < < < < < < | < < < < < < < < < | | | 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 | (if (not (null? required-tests)) (debug:print-info 1 *default-log-port* "Adding \"" (string-intersperse required-tests " ") "\" to the run queue")) ;; NOTE: these are all parent tests, items are not expanded yet. (debug:print-info 4 *default-log-port* "test-records=" (hash-table->alist test-records)) (let ((reglen (configf:lookup *configdat* "setup" "runqueue"))) (if (> (length (hash-table-keys test-records)) 0) (let* () (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry) (if (> run-count 0) ;; handle reruns (begin (if (not (hash-table-ref/default flags "-preclean" #f)) (hash-table-set! flags "-preclean" #t)) (if (not (hash-table-ref/default flags "-rerun" #f)) (hash-table-set! flags "-rerun" "ABORT,STUCK/DEAD,n/a,ZERO_ITEMS")) (runs:run-tests target runname test-patts user flags run-count: (- run-count 1))) (launch:end-of-run-check run-id))) (debug:print-info 0 *default-log-port* "No tests to run"))) (debug:print-info 4 *default-log-port* "All done by here") ;; TODO: try putting post hook call here ; (debug:print-info 2 *default-log-port* " run-count " run-count) ; (runs:run-post-hook run-id)) ; (debug:print-info 2 *default-log-port* "Not calling post hook runcount = " run-count )) |
︙ | ︙ | |||
923 924 925 926 927 928 929 930 931 932 933 934 935 936 | ;; return value of runs:expand-items is passed back to runs-tests-queue and is fed to named loop with this signature: ;; (let loop ((hed (car sorted-test-names)) ;; (tal (cdr sorted-test-names)) ;; (reg '()) ;; registered, put these at the head of tal ;; (reruns '())) (define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps) (let* ((loop-list (list hed tal reg reruns)) (prereqs-not-met (let ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))) (if (list? res) res (begin (debug:print 0 *default-log-port* "ERROR: rmt:get-prereqs-not-met returned non-list!\n" " res=" res " run-id=" run-id " waitons=" waitons " hed=" hed " item-path=" item-path " testmode=" testmode " itemmaps=" itemmaps) | > | 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 | ;; return value of runs:expand-items is passed back to runs-tests-queue and is fed to named loop with this signature: ;; (let loop ((hed (car sorted-test-names)) ;; (tal (cdr sorted-test-names)) ;; (reg '()) ;; registered, put these at the head of tal ;; (reruns '())) (define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps) (let* ((loop-list (list hed tal reg reruns)) (junk (debug:print-info 4 *default-log-port* "expand-items calling rmt:get-prereqs-not-met")) (prereqs-not-met (let ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))) (if (list? res) res (begin (debug:print 0 *default-log-port* "ERROR: rmt:get-prereqs-not-met returned non-list!\n" " res=" res " run-id=" run-id " waitons=" waitons " hed=" hed " item-path=" item-path " testmode=" testmode " itemmaps=" itemmaps) |
︙ | ︙ | |||
1012 1013 1014 1015 1016 1017 1018 | (if (list? items-list) (begin (if (null? items-list) (let ((test-id (rmt:get-test-id run-id test-name "")) (num-items (rmt:test-toplevel-num-items run-id test-name))) (if (and test-id (not (> num-items 0))) | | | 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 | (if (list? items-list) (begin (if (null? items-list) (let ((test-id (rmt:get-test-id run-id test-name "")) (num-items (rmt:test-toplevel-num-items run-id test-name))) (if (and test-id (not (> num-items 0))) (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "ZERO_ITEMS" (conc "Failed to run due to failed prerequisites: " (runs:pretty-string fails)))))) (tests:testqueue-set-items! test-record items-list) (list hed tal reg reruns)) (begin (debug:print-error 0 *default-log-port* "The proc from reading the items table did not yield a list - please report this") (exit 1)))))) ((and (null? fails) |
︙ | ︙ | |||
1048 1049 1050 1051 1052 1053 1054 | (set! give-up #t))) prereqstrs)) (if (and give-up (not (and (null? tal)(null? reg)))) (let ((trimmed-tal (mt:discard-blocked-tests run-id hed tal test-records)) (trimmed-reg (mt:discard-blocked-tests run-id hed reg test-records))) | | | | | | | | | | | 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 | (set! give-up #t))) prereqstrs)) (if (and give-up (not (and (null? tal)(null? reg)))) (let ((trimmed-tal (mt:discard-blocked-tests run-id hed tal test-records)) (trimmed-reg (mt:discard-blocked-tests run-id hed reg test-records))) (debug:print 1 *default-log-port* "WARNING: test " hed " has discarded prerequisites: " prereqstrs ", removing it from the queue") (let ((test-id (rmt:get-test-id run-id hed ""))) (if test-id (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "PREQ_DISCARDED" (conc "Failed to run due to discarded prerequisites: " prereqstrs)))) (if (and (null? trimmed-tal) (null? trimmed-reg)) #f (runs:loop-values trimmed-tal trimmed-reg reglen regfull reruns) )) (list (car newtal)(append (cdr newtal) reg) '() reruns)))) ((and (null? fails) ;; have not-started tests, but unable to run them. everything looks completed with no prospect of unsticking something that is stuck. we should mark hed as moribund and exit or continue if there are more tests to consider (null? prereq-fails) (null? non-completed)) (debug:print-info 4 *default-log-port* "cond branch - " "ei-4") (if (runs:can-keep-running? hed 20) (begin (runs:inc-cant-run-tests hed) (debug:print-info 0 *default-log-port* "no fails in prerequisites (" (runs:pretty-string prereqs-not-met) ") for " hed " but also none running, keeping " hed " for now. Try count: " (hash-table-ref/default *seen-cant-run-tests* hed 0) ", going to wait 60 sec.") ;; ;; getting here likely means the system is way overloaded, kill a full minute before continuing ;; (thread-sleep! 60) ;; TODO: gate by normalized server load > 1.0 (maxload config thing) CHECKTHIS!!! ;; No runsdat, can't do this yet ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat))) ;; (thread-sleep! 5) ;; TODO: gate by normalized server load > 1.0 (maxload config thing) ;; num-retries code was here ;; we use this opportunity to move contents of reg to tal (list (car newtal)(append (cdr newtal) reg) '() reruns)) ;; an issue with prereqs not yet met? (begin (debug:print-info 1 *default-log-port* "no fails in prerequisites (" (runs:pretty-string prereqs-not-met) ") for " hed " but nothing seen running in a while, dropping test " hed " from the run queue") (let ((test-id (rmt:get-test-id run-id hed ""))) (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "TIMED_OUT" (conc "Prerequisites (" (runs:pretty-string prereqs-not-met) ") not seen running in a while.")))) (runs:loop-values tal reg reglen regfull reruns) ))) ((and (or (not (null? fails)) (not (null? prereq-fails))) (member 'normal testmode)) (debug:print-info 4 *default-log-port* "cond branch - " "ei-5") (debug:print-info 1 *default-log-port* "test " hed " (mode=" testmode ") has failed prerequisite(s): " (string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ") ", removing it from to-do list") (let ((test-id (rmt:get-test-id run-id hed ""))) (if test-id (if (not (null? prereq-fails)) (mt:test-set-state-status-by-id-unless-completed run-id test-id "COMPLETED" "PREQ_DISCARDED" (conc "Failed to run due to prior failed prerequisites: "(runs:pretty-string prereq-fails))) (mt:test-set-state-status-by-id-unless-completed run-id test-id "COMPLETED" "PREQ_FAIL" (conc "Failed to run due to failed prerequisites: " (runs:pretty-string fails )))))) ;; (debug:print 4 *default-log-port*"BB> set PREQ_FAIL on "hed) ;; (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites")))) ;; BB: this works, btu equivalent for itemwait mode does not work. (if (or (not (null? reg))(not (null? tal))) (begin (hash-table-set! test-registry hed 'CANNOTRUN) (runs:loop-values tal reg reglen regfull (cons hed reruns)) ) #f)) ;; #f flags do not loop ((and (not (null? fails))(member 'toplevel testmode)) (debug:print-info 4 *default-log-port* "cond branch - " "ei-6") (if (or (not (null? reg))(not (null? tal))) (list (car newtal)(append (cdr newtal) reg) '() reruns) #f)) ((null? runnables) (debug:print-info 4 *default-log-port* "cond branch - " "ei-7") #f) ;; if we get here and non-completed is null then it is all over. (else (debug:print-info 4 *default-log-port* "cond branch - " "ei-8") (debug:print 2 *default-log-port* "WARNING: FAILS or incomplete tests maybe preventing completion of this run. Watch for issues with test " hed ", continuing for now") (list (car newtal)(cdr newtal) reg reruns))))) (define (runs:mixed-list-testname-and-testrec->list-of-strings inlst) (if (null? inlst) '() (map (lambda (t) (cond |
︙ | ︙ | |||
1173 1174 1175 1176 1177 1178 1179 | (registry-mutex (runs:dat-registry-mutex runsdat)) (flags (runs:dat-flags runsdat)) (keyvals (runs:dat-keyvals runsdat)) (run-info (runs:dat-run-info runsdat)) (all-tests-registry (runs:dat-all-tests-registry runsdat)) (run-limits-info (runs:dat-can-run-more-tests runsdat)) ;; (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running | | > > > > > > > > > > > > > > | 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 | (registry-mutex (runs:dat-registry-mutex runsdat)) (flags (runs:dat-flags runsdat)) (keyvals (runs:dat-keyvals runsdat)) (run-info (runs:dat-run-info runsdat)) (all-tests-registry (runs:dat-all-tests-registry runsdat)) (run-limits-info (runs:dat-can-run-more-tests runsdat)) ;; (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running (have-resources (and #; (if *journal-stats* (let* ((dbfname (conc (dbfile:run-id->dbnum run-id) ".db")) (load (tt:get-journal-stats dbfname))) (if (> load 0.1) ;; dbs too busy to start more tests (begin (debug:print-info 0 *default-log-port* "Gating launch due to db load "load" based on journal file observations for "dbfname) #f) #t)) (begin (debug:print-info 0 *default-log-port* "Journal gating not started for "run-id) #t)) ;; if journal monitoring not started do not gate (car run-limits-info))) (num-running (list-ref run-limits-info 1)) (num-running-in-jobgroup(list-ref run-limits-info 2)) (max-concurrent-jobs (list-ref run-limits-info 3)) (job-group-limit (list-ref run-limits-info 4)) ;; (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)) ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) (prereqs-running (runs:calc-prereqs-running prereqs-not-met)) (fails (if (list? prereqs-not-met) ;; TODO: rename fails to failed-prereqs (runs:calc-fails prereqs-not-met) (begin (debug:print-error 0 *default-log-port* "prereqs-not-met is not a list! " prereqs-not-met) '()))) (non-completed (filter (lambda (x) ;; remove hed from not completed list, duh, of course it is not completed! (not (equal? x hed))) |
︙ | ︙ | |||
1219 1220 1221 1222 1223 1224 1225 | (if (and (not (common:on-homehost?)) maxload) ;; only gate if maxload is specified, NOTE: maxload is normalized, i.e. load=1 means all cpus fully utilized (common:wait-for-normalized-load maxload "Waiting for load to drop before starting more tests" #f)) ;; jobtools maxhomehostload is intended to prevent overloading on the homehost which can cause database corruption issues (if maxhomehostload (common:wait-for-homehost-load maxhomehostload | | | > > | > > | 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 | (if (and (not (common:on-homehost?)) maxload) ;; only gate if maxload is specified, NOTE: maxload is normalized, i.e. load=1 means all cpus fully utilized (common:wait-for-normalized-load maxload "Waiting for load to drop before starting more tests" #f)) ;; jobtools maxhomehostload is intended to prevent overloading on the homehost which can cause database corruption issues (if maxhomehostload (common:wait-for-homehost-load maxhomehostload (conc "Waiting for homehost load to drop below normalized value of " maxhomehostload))) ;; lastly lets check the servers are not overloaded by looking at threads (tt:wait-on-server-load run-id *ttdat*) ))) (if (and (not (null? prereqs-not-met)) (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60)) (debug:print-info 2 *default-log-port* "waiting on tests; " (string-intersperse (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) ", "))) ;; Don't know at this time if the test have been launched at some time in the past ;; i.e. is this a re-launch? |
︙ | ︙ | |||
1290 1291 1292 1293 1294 1295 1296 | ", ")) (thread-sleep! 0.051) (list hed tal reg reruns)) ;; If no resources are available just kill time and loop again ;; ((not have-resources) ;; simply try again after waiting a second | | > > > > > > > > | > | 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 | ", ")) (thread-sleep! 0.051) (list hed tal reg reruns)) ;; If no resources are available just kill time and loop again ;; ((not have-resources) ;; simply try again after waiting a second (if (runs:lownoise "no resources" 600) (debug:print-info 1 *default-log-port* "no resources to run new tests, waiting ...")) ;; Have gone back and forth on this but db starvation is an issue. ;; wait one second before looking again to run jobs. ;; (thread-sleep! 0.25) ;; new logic. ;; If it has been more than 10 seconds since we were last here don't wait at all ;; otherwise sleep 2 seconds to give db a rest and let dashboard read data (if (runs:lownoise "frequent-no-resources" 10) (thread-sleep! 0.25) ;; no significant delay (thread-sleep! 2)) ;; could have done hed tal here but doing car/cdr of newtal to rotate tests (list (car newtal)(cdr newtal) reg reruns)) ;; This is the final stage, everything is in place so launch the test ;; ((and have-resources (or (null? prereqs-not-met) (and (member 'toplevel testmode) ;; 'toplevel) (null? non-completed) (not (member 'exclusive testmode))))) ;; (hash-table-delete! *max-tries-hash* (db:test-make-full-name test-name item-path)) ;; we are going to reset all the counters for test retries by setting a new hash table ;; this means they will increment only when nothing can be run (set! *max-tries-hash* (make-hash-table)) (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry runsdat testdat) (set! *last-test-launch* (current-seconds)) (runs:incremental-print-results run-id) (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running) (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) (if (or (not (null? tal))(not (null? reg))) (runs:loop-values tal reg reglen regfull reruns) ;; hed should be dropped at this time #f)) |
︙ | ︙ | |||
1344 1345 1346 1347 1348 1349 1350 | ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat))) (thread-sleep! 5) (list (car newtal)(cdr newtal) reg reruns)) ;; the waiton is FAIL so no point in trying to run hed ever again (begin (let ((my-test-id (rmt:get-test-id run-id test-name item-path))) | | | | < | < | > | | | | > > > | | > | | 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 | ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat))) (thread-sleep! 5) (list (car newtal)(cdr newtal) reg reruns)) ;; the waiton is FAIL so no point in trying to run hed ever again (begin (let ((my-test-id (rmt:get-test-id run-id test-name item-path))) (mt:test-set-state-status-by-id-unless-completed run-id my-test-id "COMPLETED" "PREQ_FAIL" (conc "Failed to run due to failed prerequisites: " (runs:pretty-string fails)))) (if (or (not (null? reg))(not (null? tal))) (if (vector? hed) (begin (debug:print 1 *default-log-port* "WARNING: Dropping test " test-name "/" item-path " from the launch list as it has prerequistes that are FAIL: " (runs:pretty-string fails)) (let ((test-id (rmt:get-test-id run-id hed ""))) (if test-id (mt:test-set-state-status-by-id-unless-completed run-id test-id "COMPLETED" "PREQ_FAIL" (conc "Failed to run due to failed prerequisites: " (runs:pretty-string fails)) ))) (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) ;; This next is for the items (if (not (null? fails)) (rmt:set-state-status-and-roll-up-items run-id test-name item-path "NOT_STARTED" "PREQ_FAIL" (runs:pretty-string fails)) (rmt:set-state-status-and-roll-up-items run-id test-name item-path "NOT_STARTED" "BLOCKED" #f) ) (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'removed) (runs:loop-values tal reg reglen regfull reruns)) (let ((nth-try (hash-table-ref/default test-registry hed 0))) ;; hed not a vector... (debug:print 2 *default-log-port* "nth-try("hed")="nth-try) (cond ;;((member "RUNNING" (map db:test-get-state prereqs-not-met)) ((> 0 (length prereqs-running)) (if (runs:lownoise (conc "possible RUNNING prerequisites " hed) 60) (debug:print 0 *default-log-port* "WARNING: test " hed " has possible RUNNING prerequisites: " prereqs-running ", don't give up on it yet.")) (thread-sleep! 0.1) (runs:loop-values tal reg reglen regfull reruns)) ((or (not nth-try) ;; BB: condition on subsequent tries, condition below fires on first try (and (number? nth-try) (< nth-try 2))) (hash-table-set! test-registry hed (if (number? nth-try) (+ nth-try 1) 0)) (if (runs:lownoise (conc "not removing test " hed) 60) (debug:print 1 *default-log-port* "WARNING: not removing test " hed " from queue although it may not be runnable due to FAILED prerequisites: "(runs:pretty-string fails))) ;; may not have processed correctly. Could be a race condition in your test implementation? Dropping test " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)") (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) (runs:loop-values newtal reg reglen regfull reruns)) ((symbol? nth-try) ;; BB: 'done matches here in one case where prereq itemwait failed. This is first "try" (if (eq? nth-try 'removed) ;; removed is removed - drop it NOW (if (null? tal) #f ;; yes, really (list (car tal)(cdr tal) reg reruns)) (begin (if (runs:lownoise (conc "FAILED prerequisites or other issue" hed) 60) (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequisites (" (runs:pretty-string fails)") or other issue. Internal state >" nth-try "< will be overridden and we'll retry.")) (let* ((test-id (rmt:get-test-id run-id hed item-path)) (test-info (rmt:get-testinfo-state-status run-id test-id)) ;; we need *current* info (status (db:test-get-status test-info))) (if (equal? status "KEEP_TRYING") (mt:test-set-state-status-by-testname-unless-completed run-id test-name item-path "COMPLETED" "PREQ_FAIL" #f) (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "KEEP_TRYING" #f))) (hash-table-set! test-registry hed 'removed) ;; was 0 (if (not (and (null? reg) (null? tal))) (runs:loop-values tal reg reglen regfull reruns) #f)))) (else (if (runs:lownoise (conc "FAILED prerequitests and we tried" hed) 60) (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequitests: " (runs:pretty-string fails) " and we've tried at least 10 times to run it. Giving up now.")) ;; (debug:print 0 *default-log-port* " prereqs: " prereqs-not-met) (hash-table-set! test-registry hed 'removed) (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "TEN_STRIKES" #f) ;; I'm unclear on if this roll up is needed - it may be the root cause of the "all set to FAIL" bug. (rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "FAIL" #f) ;; treat as FAIL (list (if (null? tal)(car newtal)(car tal)) tal |
︙ | ︙ | |||
1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 | ;; 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)) (define (runs:pretty-long-list lst) (if (> (length lst) 8)(append (take lst 3)(list "...")) lst)) ;;====================================================================== ;; runs:run-tests-queue is called by runs:run-tests ;;====================================================================== ;; ;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... > (define (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests reglen-in all-tests-registry) | > > | 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 | ;; 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)) (define (runs:pretty-long-list lst) (if (> (length lst) 8)(append (take lst 3)(list "...")) lst)) (define *last-loop-time-ms* 0) ;;====================================================================== ;; runs:run-tests-queue is called by runs:run-tests ;;====================================================================== ;; ;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... > (define (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests reglen-in all-tests-registry) |
︙ | ︙ | |||
1552 1553 1554 1555 1556 1557 1558 1559 | (registry-mutex (make-mutex)) (num-retries 0) (max-retries (configf:lookup *configdat* "setup" "maxretries")) (max-concurrent-jobs (configf:lookup-number *configdat* "setup" "max_concurrent_jobs" default: 50)) (reglen (if (number? reglen-in) reglen-in 1)) (last-time-incomplete (- (current-seconds) 900)) ;; force at least one clean up cycle (last-time-some-running (current-seconds)) ;; (tdbdat (tasks:open-db)) | > < | 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 | (registry-mutex (make-mutex)) (num-retries 0) (max-retries (configf:lookup *configdat* "setup" "maxretries")) (max-concurrent-jobs (configf:lookup-number *configdat* "setup" "max_concurrent_jobs" default: 50)) (reglen (if (number? reglen-in) reglen-in 1)) (last-time-incomplete (- (current-seconds) 900)) ;; force at least one clean up cycle (last-time-some-running (current-seconds)) (incoming-tests '()) ;; queue up incoming tests here to tack on to tal when it gets low ;; (tdbdat (tasks:open-db)) (runsdat (make-runs:dat ;; hed: hed ;; tal: tal ;; reg: reg ;; reruns: reruns reglen: reglen regfull: #f ;; regfull |
︙ | ︙ | |||
1614 1615 1616 1617 1618 1619 1620 | ;; (if (> (current-seconds)(+ last-time-incomplete 900)) (begin (set! last-time-incomplete (current-seconds)) ;; (rmt:find-and-mark-incomplete-all-runs) )) | < < < < < < | 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 | ;; (if (> (current-seconds)(+ last-time-incomplete 900)) (begin (set! last-time-incomplete (current-seconds)) ;; (rmt:find-and-mark-incomplete-all-runs) )) ;; (print "Top of loop, hed=" hed ", tal=" tal " ,reruns=" reruns) (let* ((test-record (hash-table-ref test-records hed)) (test-name (tests:testqueue-get-testname test-record)) (tconfig (tests:testqueue-get-testconfig test-record)) (jobgroup (configf:lookup tconfig "test_meta" "jobgroup")) (testmode (let ((m (configf:lookup tconfig "requirements" "mode"))) (if m (map string->symbol (string-split m)) '(normal)))) |
︙ | ︙ | |||
1669 1670 1671 1672 1673 1674 1675 | test-name: test-name item-path: item-path jobgroup: jobgroup waitons: waitons testmode: testmode newtal: newtal itemmaps: itemmaps | | > > > > > > > > > > > > | > > > > > | 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 | test-name: test-name item-path: item-path jobgroup: jobgroup waitons: waitons testmode: testmode newtal: newtal itemmaps: itemmaps prereqs-not-met: '() ))) ;; too-tight loop detection and delay, this might hide issues ;; that occur in long run times. Consider commenting when debugging ;; (if (and (>= num-running max-concurrent-jobs) (< (- (current-milliseconds) *last-loop-time-ms*) 500)) (begin (if (runs:lownoise "too-tight-loop" 5) (debug:print-info 2 *default-log-port* "Excessively fast loop, delaying 1/2 second")) (thread-sleep! 0.5))) (set! *last-loop-time-ms* (current-milliseconds)) (runs:dat-regfull-set! runsdat regfull) (if (> (- (current-seconds) *last-test-launch*) 5) ;; be pretty aggressive for five seconds after (runs:too-soon-delay (conc "loop delay " hed) 1 0.6) ;; starting a test then apply more delay (runs:too-soon-delay (conc "loop delay " hed) 1 0.1)) (if (> num-running 0) (set! last-time-some-running (current-seconds))) (if (> (current-seconds)(+ last-time-some-running (or (configf:lookup *configdat* "setup" "give-up-waiting") 36000))) (hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1))) ;; (debug:print 0 *default-log-port* "max-tries-hash: " (hash-table->alist *max-tries-hash*)) |
︙ | ︙ | |||
1700 1701 1702 1703 1704 1705 1706 | (debug:print-info 0 *default-log-port* "Skipping test " tfullname " as it has been marked do not run due to being completed or not runnable")) (if (or (not (null? tal))(not (null? reg))) (loop (runs:queue-next-hed tal reg reglen regfull) (runs:queue-next-tal tal reg reglen regfull) (runs:queue-next-reg tal reg reglen regfull) reruns)))) ;; (loop (car tal)(cdr tal) reg reruns)))) | < | 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 | (debug:print-info 0 *default-log-port* "Skipping test " tfullname " as it has been marked do not run due to being completed or not runnable")) (if (or (not (null? tal))(not (null? reg))) (loop (runs:queue-next-hed tal reg reglen regfull) (runs:queue-next-tal tal reg reglen regfull) (runs:queue-next-reg tal reg reglen regfull) reruns)))) ;; (loop (car tal)(cdr tal) reg reruns)))) (runs:incremental-print-results run-id) (debug:print 4 *default-log-port* "TOP OF LOOP => " "test-name: " test-name "\n hed: " hed "\n tal: " (runs:pretty-long-list tal) "\n reg: " reg "\n test-record " test-record |
︙ | ︙ | |||
1774 1775 1776 1777 1778 1779 1780 | (let* ((jobgroup (runs:testdat-jobgroup testdat-in)) (can-run-more-tests (runs:dat-can-run-more-tests runsdat)) (last-jobs-check-time (runs:dat-last-jobs-check-time runsdat)) (should-check-jobs (match can-run-more-tests ((can-run-more-flag num-running nr-in-jobgroup max-concurrent-jobs . params) (if (< (- max-concurrent-jobs num-running) 25) (begin | | | 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 | (let* ((jobgroup (runs:testdat-jobgroup testdat-in)) (can-run-more-tests (runs:dat-can-run-more-tests runsdat)) (last-jobs-check-time (runs:dat-last-jobs-check-time runsdat)) (should-check-jobs (match can-run-more-tests ((can-run-more-flag num-running nr-in-jobgroup max-concurrent-jobs . params) (if (< (- max-concurrent-jobs num-running) 25) (begin (debug:print-info 2 *default-log-port* "less than 20 jobs headroom, ("max-concurrent-jobs "-"num-running")>20. Forcing prelaunch check.") #t) #f)) (else #f)))) ;; no record yet (if should-check-jobs (let loop-can-run-more |
︙ | ︙ | |||
1805 1806 1807 1808 1809 1810 1811 | ;; wait for load here (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat))) (loop-can-run-more (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs) (- remtries 1))))))) ))))) ;; I'm not clear on why prereqs are gathered here TODO: verfiy this is needed | < < < | 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 | ;; wait for load here (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat))) (loop-can-run-more (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs) (- remtries 1))))))) ))))) ;; I'm not clear on why prereqs are gathered here TODO: verfiy this is needed (runs:testdat-prereqs-not-met-set! testdat (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)) ;; I'm not clear on why we'd capture running job counts here TODO: verify this is needed (runs:dat-can-run-more-tests-set! runsdat (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)) (let ((loop-list (runs:process-expanded-tests runsdat testdat))) ;; in process-expanded-tests ultimately run:test -> launch-test -> test actually running (if loop-list (apply loop loop-list)))) |
︙ | ︙ | |||
1857 1858 1859 1860 1861 1862 1863 | (my-item-path (item-list->path my-itemdat)) (newtestname (db:test-make-full-name hed my-item-path))) ;; test names are unique on testname/item-path (tests:testqueue-set-items! new-test-record #f) (tests:testqueue-set-itemdat! new-test-record my-itemdat) (tests:testqueue-set-item_path! new-test-record my-item-path) (hash-table-set! test-records newtestname new-test-record) | > > > > | | > > > > | 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 | (my-item-path (item-list->path my-itemdat)) (newtestname (db:test-make-full-name hed my-item-path))) ;; test names are unique on testname/item-path (tests:testqueue-set-items! new-test-record #f) (tests:testqueue-set-itemdat! new-test-record my-itemdat) (tests:testqueue-set-item_path! new-test-record my-item-path) (hash-table-set! test-records newtestname new-test-record) ;; BUG: This next line sucks up a lot of horsepower ;; (set! tal (append tal (list newtestname))) ;; (set! tal (cons newtestname tal)) ;; 4/6/2023 - try using cons, does it matter if the test gets added at the beginning? (set! incoming-tests (cons newtestname incoming-tests)) )) ;; since these are itemized create new test names testname/itempath items-in-testpatt))) (if (and (< (length tal) 20) (not (null? incoming-tests))) (begin (set! tal (append tal (reverse incoming-tests))) (set! incoming-tests '()))) ;; At this point we have possibly added items to tal but all must be handed off to ;; INNER COND logic. I think loop without rotating the queue ;; (loop hed tal reg reruns)) ;; (let ((newtal (append tal (list hed)))) ;; We should discard hed as it has been expanded into it's items? Yes, but only if this *is* an itemized test ;; (loop (car newtal)(cdr newtal) reg reruns) (if (null? tal) |
︙ | ︙ | |||
1887 1888 1889 1890 1891 1892 1893 | (if loop-list (apply loop loop-list) (debug:print-info 4 *default-log-port* " -- Can't expand hed="hed) ) ) ;; if can't run more just loop with next possible test (loop (car newtal)(cdr newtal) reg reruns)))) | | > > > | < | | | < | | 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 | (if loop-list (apply loop loop-list) (debug:print-info 4 *default-log-port* " -- Can't expand hed="hed) ) ) ;; if can't run more just loop with next possible test (loop (car newtal)(cdr newtal) reg reruns)))) ;; this case should not happen, added to help catch any bugs ((and (list? items) itemdat) (debug:print-info 4 *default-log-port* "cond branch - " "rtq-5") (debug:print-error 0 *default-log-port* "Should not have a list of items in a test and the itemspath set - please report this") (exit 1)) ((not (null? reruns)) (debug:print-info 4 *default-log-port* "cond branch - " "rtq-6") (let* ((newlst (tests:filter-non-runnable run-id tal test-records)) ;; i.e. not FAIL, WAIVED, INCOMPLETE, PASS, KILLED, (junked (lset-difference equal? tal newlst))) (debug:print-info 4 *default-log-port* "full drop through, if reruns is less than 100 we will force retry them, reruns=" reruns ", tal=" tal) (if (< num-retries max-retries) (set! newlst (append reruns newlst))) (set! num-retries (+ num-retries 1)) ;; (thread-sleep! (+ 1 *global-delta*)) (if (not (null? newlst)) ;; since reruns have been tacked on to newlst create new reruns from junked (loop (car newlst)(cdr newlst) reg (delete-duplicates junked))))) ((not (null? tal)) (debug:print-info 4 *default-log-port* "cond branch - " "rtq-7") (debug:print-info 4 *default-log-port* "I'm pretty sure I shouldn't get here.")) ((not (null? reg)) ;; could we get here with leftovers? (debug:print-info 4 *default-log-port* "cond branch - " "rtq-8") (debug:print-info 0 *default-log-port* "Have leftovers!") (loop (car reg)(cdr reg) '() reruns)) (else (debug:print-info 4 *default-log-port* "cond branch - " "rtq-9") (debug:print-info 4 *default-log-port* "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns)) ))) ;; 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) ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat))) (thread-sleep! 0.1) ;; 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)) (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))) (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)))))) ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat))) (thread-sleep! 5) ;; (if (>= num-running max-concurrent-jobs) 5 1)) (wait-loop (rmt:get-count-tests-running-for-run-id run-id) 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"))) (define (runs:calc-fails prereqs-not-met) (filter (lambda (test) (and (vector? test) ;; not (string? test)) (member (db:test-get-state test) '("INCOMPLETE" "COMPLETED")) ;; TODO: pull from *common:stuff...* (not (member (db:test-get-status test) '("PASS" "WARN" "WAIVED" "SKIP"))))) prereqs-not-met)) (define (runs:calc-prereq-fail prereqs-not-met) ;; REMOVEME since NOT_STARTED/PREQ_FAIL is now COMPLETED/PREQ_FAIL (filter (lambda (test) (and (vector? test) ;; not (string? test)) (equal? (db:test-get-state test) "NOT_STARTED") (not (member (db:test-get-status test) |
︙ | ︙ | |||
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 | (lambda (t) (or (not (vector? t)) (and (equal? "NOT_STARTED" (db:test-get-state t)) (member (db:test-get-status t) '("n/a" "KEEP_TRYING"))) (and (equal? "RUNNING" (db:test-get-state t))))) ;; account for a test that is running prereqs-not-met)) (define (runs:pretty-string lst) (map (lambda (t) (if (not (vector? t)) (conc t) (conc (db:test-get-testname t) ":" (db:test-get-state t) "/" (db:test-get-status t)))) lst)) ;; parent-test is there as a placeholder for when parent-tests can be run as a setup step ;; (define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry runsdat testdat-rec) ;; All these vars might be referenced by the testconfig file reader ;; ;; NEED to reprocess testconfig here, ensuring that item variables are available. ;; This is for Tal's issue with item-specific env vars not being set for use in skip. ;; HSD https://hsdes.intel.com/appstore/icf/index.html#/article?articleId=1408763273 ;; (let* ((test-name (tests:testqueue-get-testname test-record)) (test-waitons (tests:testqueue-get-waitons test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) (item-path "") (db #f) (full-test-name #f)) ;; setting itemdat to a list if it is #f (if (not itemdat)(set! itemdat '())) (set! item-path (item-list->path itemdat)) (set! full-test-name (db:test-make-full-name test-name item-path)) (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) ;; these may be needed by the launching process | > > > > > > > > > > > > > > | > | < | 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 | (lambda (t) (or (not (vector? t)) (and (equal? "NOT_STARTED" (db:test-get-state t)) (member (db:test-get-status t) '("n/a" "KEEP_TRYING"))) (and (equal? "RUNNING" (db:test-get-state t))))) ;; account for a test that is running prereqs-not-met)) (define (runs:calc-prereqs-running prereqs-not-met) (if (list? prereqs-not-met) (filter (lambda (t) (or (not (vector? t)) (member (db:test-get-state t) '("RUNNING" "LAUNCHED" "REMOTE_HOST_START")) )) prereqs-not-met) '() ) ) (define (runs:pretty-string lst) (map (lambda (t) (if (not (vector? t)) (conc t) (conc (db:test-get-testname t) ":" (db:test-get-state t) "/" (db:test-get-status t)))) lst)) ;; parent-test is there as a placeholder for when parent-tests can be run as a setup step ;; (define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry runsdat testdat-rec) ;; All these vars might be referenced by the testconfig file reader ;; ;; NEED to reprocess testconfig here, ensuring that item variables are available. ;; This is for Tal's issue with item-specific env vars not being set for use in skip. ;; HSD https://hsdes.intel.com/appstore/icf/index.html#/article?articleId=1408763273 ;; Also later HSD https://hsdes.intel.com/appstore/article/#/14012138487 ;; (let* ((test-name (tests:testqueue-get-testname test-record)) (test-waitons (tests:testqueue-get-waitons test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) (item-path "") (db #f) (full-test-name #f)) ;; setting itemdat to a list if it is #f (if (not itemdat)(set! itemdat '())) (set! item-path (item-list->path itemdat)) (set-item-env-vars itemdat) (set! full-test-name (db:test-make-full-name test-name item-path)) (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) ;; these may be needed by the launching process (let* ((test-conf ;; re-instated the tests:get-testconfig to fix HSD https://hsdes.intel.com/appstore/article/#/14012138487, need to be able to skip using [items], [itemstable] variables. ;; (tests:testqueue-get-testconfig test-record )) ;; vector-ref test-record 3 (tests:get-testconfig test-name item-path all-tests-registry #t force-create: #t)) (test-path (hash-table-ref all-tests-registry test-name)) ;; (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ... (force (hash-table-ref/default flags "-force" #f)) (rerun (hash-table-ref/default flags "-rerun" #f)) (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) (incomplete-timeout (string->number (or (configf:lookup *configdat* "setup" "incomplete-timeout") "x"))) ) |
︙ | ︙ | |||
2053 2054 2055 2056 2057 2058 2059 | ;; Here is where the test_meta table is best updated ;; Yes, another use of a global for caching. Need a better way? ;; ;; There is now a single call to runs:update-all-test_meta and this ;; per-test call is not needed. Given the delicacy of the move to ;; v1.55 this code is being left in place for the time being. ;; | | | 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 | ;; Here is where the test_meta table is best updated ;; Yes, another use of a global for caching. Need a better way? ;; ;; There is now a single call to runs:update-all-test_meta and this ;; per-test call is not needed. Given the delicacy of the move to ;; v1.55 this code is being left in place for the time being. ;; (if (not (hash-table-exists? *test-meta-updated* test-name)) (begin (hash-table-set! *test-meta-updated* test-name #t) (runs:update-test_meta test-name test-conf))) ;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer")) (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) (test-id (rmt:get-test-id run-id test-name item-path)) |
︙ | ︙ | |||
2146 2147 2148 2149 2150 2151 2152 | (set! runflag #t)) (else (set! runflag #f))) (debug:print 4 *default-log-port* "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat)) (if (not runflag) (if (not parent-test) (if (runs:lownoise (conc "not starting test" full-test-name) 60) | | | 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 | (set! runflag #t)) (else (set! runflag #f))) (debug:print 4 *default-log-port* "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat)) (if (not runflag) (if (not parent-test) (if (runs:lownoise (conc "not starting test" full-test-name) 60) (debug:print 3 *default-log-port* "NOTE: Not starting test " full-test-name " as it is state \"" (test:get-state testdat) "\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-status testdat) "\" or -force to override"))) ;; NOTE: No longer be checking prerequisites here! Will never get here unless prereqs are ;; already met. ;; This would be a great place to do the process-fork ;; (let ((skip-test #f) |
︙ | ︙ | |||
2211 2212 2213 2214 2215 2216 2217 | (begin ;; wait for less than max jobs here (if (runs:dat-wait-for-jobs-function runsdat) ((runs:dat-wait-for-jobs-function runsdat) testdat-rec)) (if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags)) (begin | | | 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 | (begin ;; wait for less than max jobs here (if (runs:dat-wait-for-jobs-function runsdat) ((runs:dat-wait-for-jobs-function runsdat) testdat-rec)) (if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags)) (begin (debug:print 0 *default-log-port* "ERROR: Failed to launch the test. Exiting as soon as possible") (set! *globalexitstatus* 1) ;; (process-signal (current-process-id) signal/kill)) ) ;; wait again here? )))))) ((KILLED) (debug:print 1 *default-log-port* "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.") |
︙ | ︙ | |||
2314 2315 2316 2317 2318 2319 2320 | (action-chk (member (string->symbol "remove-runs") actions))) ;; check the sequence of actions archive must comme before remove-runs (if (and action-chk (member (string->symbol "archive") action-chk)) (begin (debug:print-error 0 *default-log-port* "action remove-runs must come after archive") (exit 1))) (print "Actions: " actions " age: " age) | < < < < < < < < < < < < | | | | | < < | | < < < | < < | < < | 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 | (action-chk (member (string->symbol "remove-runs") actions))) ;; check the sequence of actions archive must comme before remove-runs (if (and action-chk (member (string->symbol "archive") action-chk)) (begin (debug:print-error 0 *default-log-port* "action remove-runs must come after archive") (exit 1))) (print "Actions: " actions " age: " age) (for-each (lambda (action) (for-each (lambda (target) (let* ((runs (hash-table-ref runs-ht target)) (sorted (sort runs (lambda (a b)(< (simple-run-event_time a)(simple-run-event_time b))))) (to-remove (let* ((len (length sorted)) (trim-amt (- len num-to-keep))) (if (> trim-amt 0) (take sorted trim-amt) '())))) (hash-table-set! runs-ht target to-remove) (print target ":") (for-each (lambda (run) (let ((remove (member run to-remove (lambda (a b) (eq? (simple-run-id a) (simple-run-id b)))))) (if (and age (> (simple-run-event_time run) age-mark)) (print "Skipping handling of " target "/" (simple-run-runname run) " as it is younger than " (args:get-arg "-age")) (case action ((print) (print " " (simple-run-runname run) " " (time->string (seconds->local-time (simple-run-event_time run)) "WW%V.%u %H:%M:%S") " " (if remove "REMOVE" ""))) ((remove-runs) (if remove (system (conc precmd " megatest -remove-runs -target " target " -runname " (simple-run-runname run) " -testpatt %" (if (member 'kill-runs actions) ;; if kill-runs is specified then set -kill-wait to 0 " -kill-wait 0" ""))))) ((archive) (if remove (system (conc precmd " megatest -archive save-remove -target " target " -runname " (simple-run-runname run) " -testpatt %")))) ((kill-runs) (if remove (system (conc precmd " megatest -kill-runs -target " target " -runname " (simple-run-runname run) " -testpatt %")))))))) sorted))) (hash-table-keys runs-ht))) actions) runs-ht)) (define (remove-last-path-directory path-in) (let* ((dparts (string-split path-in "/")) |
︙ | ︙ | |||
2400 2401 2402 2403 2404 2405 2406 | (state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f))) (rp-mutex (make-mutex)) (bup-mutex (make-mutex)) (keep-records (args:get-arg "-keep-records")) ;; used in conjunction with -remove-runs to keep the records, TODO: consolidate this with "mode". (test-records '())) ;; for tasks that we wish to operate on all tests in one fell swoop (let* ((write-access-actions '(remove-runs set-state-status archive run-wait kill-runs)) | | | | 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 | (state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f))) (rp-mutex (make-mutex)) (bup-mutex (make-mutex)) (keep-records (args:get-arg "-keep-records")) ;; used in conjunction with -remove-runs to keep the records, TODO: consolidate this with "mode". (test-records '())) ;; for tasks that we wish to operate on all tests in one fell swoop (let* ((write-access-actions '(remove-runs set-state-status archive run-wait kill-runs)) (dbfile (conc *toppath* "/.mtdb/main.db")) (readonly-mode (not (file-write-access? dbfile)))) (when (and readonly-mode (member action write-access-actions)) (debug:print-error 0 *default-log-port* dbfile " is readonly. Cannot proceed with action ["action"] in which write-access isrequired .") (exit 1))) (debug:print-info 4 *default-log-port* "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status) (if (> 2 (length state-status)) (begin (debug:print-error 0 *default-log-port* "the parameter to -set-state-status is a comma delimited string. E.g. COMPLETED,FAIL") (exit))) |
︙ | ︙ | |||
2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 | (begin (case action ((kill-runs) (tasks:kill-runner target run-name "%") (debug:print 1 *default-log-port* "Killing tests for run: " runkey " " (db:get-value-by-header run header "runname")) ) ((remove-runs) ;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) ;; seek and kill in flight -runtests with % as testpatt here ;; (if (equal? testpatt "%") (tasks:kill-runner target run-name testpatt) ;; (debug:print 0 *default-log-port* "not attempting to kill any run launcher processes as testpatt is " testpatt)) (debug:print 1 *default-log-port* "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((set-state-status) ;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) | > > | | 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 | (begin (case action ((kill-runs) (tasks:kill-runner target run-name "%") (debug:print 1 *default-log-port* "Killing tests for run: " runkey " " (db:get-value-by-header run header "runname")) ) ((remove-runs) ;; use this location to cleanup old DELETED records? No. See below for same call ;; (rmt:delete-old-deleted-test-records run-id) ;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) ;; seek and kill in flight -runtests with % as testpatt here ;; (if (equal? testpatt "%") (tasks:kill-runner target run-name testpatt) ;; (debug:print 0 *default-log-port* "not attempting to kill any run launcher processes as testpatt is " testpatt)) (debug:print 1 *default-log-port* "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((set-state-status) ;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) (debug:print 2 *default-log-port* "Modifying state and status for tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((print-run) (debug:print 1 *default-log-port* "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header) action) ((run-wait) (debug:print 1 *default-log-port* "Waiting for run " runkey ", run=" runnamepatt " to complete")) ((archive) (debug:print 1 *default-log-port* "Archiving/restoring (" (args:get-arg "-archive") ") data for run: " runkey " " (db:get-value-by-header run header "runname")) |
︙ | ︙ | |||
2593 2594 2595 2596 2597 2598 2599 | ) ) ; end case rem-status ) ; end let ); end cond has-subrun (else ;; BB - TODO - consider backgrounding to threads to delete tests (work below) | | | 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 | ) ) ; end case rem-status ) ; end let ); end cond has-subrun (else ;; BB - TODO - consider backgrounding to threads to delete tests (work below) (debug:print-info 2 *default-log-port* "test: " test-name " itest-state: " test-state) (if (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ")) (begin (if (not (hash-table-ref/default test-retry-time test-fulln #f)) (begin ;; want to set to REMOVING BUT CANNOT do it here? (hash-table-set! test-retry-time test-fulln (current-seconds)))) (if (> (- (current-seconds)(hash-table-ref test-retry-time test-fulln)) allow-run-time) |
︙ | ︙ | |||
2640 2641 2642 2643 2644 2645 2646 | (debug:print 2 *default-log-port* "Has target: " (tests:glob-like-match (conc "%/" target "/%") rundir)) (debug:print 2 *default-log-port* "Target: " target) ;;PJH remove record from db no need to cleanup directory (case mode ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) (db:test-get-state test)(db:test-get-status test) #f)) ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVED" #f #f)) | | < < < < | | 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 | (debug:print 2 *default-log-port* "Has target: " (tests:glob-like-match (conc "%/" target "/%") rundir)) (debug:print 2 *default-log-port* "Target: " target) ;;PJH remove record from db no need to cleanup directory (case mode ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) (db:test-get-state test)(db:test-get-status test) #f)) ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVED" #f #f)) (else (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test))))))) (if (not (null? tal)) (loop (car tal)(cdr tal))))))) (rmt:update-run-stats run-id 'run)) ;; (rmt:get-raw-run-stats run-id))) ((kill-runs) ;; RUNNING -> KILLREQ ;; LAUNCHED,RUNNING,REMOTEHOSTSTART -> NOT STARTED (cond ((and has-subrun (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ"))) (common:send-thunk-to-background-thread (lambda () |
︙ | ︙ | |||
2734 2735 2736 2737 2738 2739 2740 | (debug:print 2 *default-log-port* "run-paths-hash: " (hash-table-keys run-paths-hash)) (debug:print 1 *default-log-port* "Removing target " target "run: " run-name) (if (not keep-records) (begin (debug:print 1 *default-log-port* "Removing DB records for the run.") (rmt:delete-run run-id) | | | | | 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 | (debug:print 2 *default-log-port* "run-paths-hash: " (hash-table-keys run-paths-hash)) (debug:print 1 *default-log-port* "Removing target " target "run: " run-name) (if (not keep-records) (begin (debug:print 1 *default-log-port* "Removing DB records for the run.") (rmt:delete-run run-id) (rmt:delete-old-deleted-test-records run-id)) ) (if (not (equal? linkspath "/does/not/exist/I")) (begin (debug:print 1 *default-log-port* "Recursively removing links dir " linkspath) (runs:recursive-delete-with-error-msg linkspath))) (for-each (lambda(runpath) (debug:print 1 *default-log-port* "Recursively removing runs dir " runpath) (runs:recursive-delete-with-error-msg runpath) ) runpaths ) ))))) )) 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 (debug:print 0 *default-log-port* "db archive started") (archive:megatest-db target runnamepatt) (debug:print 0 *default-log-port* "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) |
︙ | ︙ | |||
2788 2789 2790 2791 2792 2793 2794 | ;; (thread-sleep! 1) ;; (loop (rmt:no-sync-get-lock lock-key) expire-time))))))) ) (case clean-mode ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f)) ((remove-all) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f)) ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f))) | | | 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 | ;; (thread-sleep! 1) ;; (loop (rmt:no-sync-get-lock lock-key) expire-time))))))) ) (case clean-mode ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f)) ((remove-all) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f)) ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f))) (debug:print-info 2 *default-log-port* "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir) (if (and real-dir (> (string-length real-dir) 5) (common:file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc. (let* ((realpath (resolve-pathname run-dir))) (debug:print-info 1 *default-log-port* "Recursively removing " realpath) (if (common:file-exists? realpath) (runs:safe-delete-test-dir realpath) |
︙ | ︙ | |||
2926 2927 2928 2929 2930 2931 2932 | (lambda (key) (let* ((idx (cadr key)) (fld (car key)) (val (configf:lookup test-conf "test_meta" fld))) ;; (debug:print 5 *default-log-port* "idx: " idx " fld: " fld " val: " val) (if (and val (not (equal? (vector-ref currrecord idx) val))) (begin | | | 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 | (lambda (key) (let* ((idx (cadr key)) (fld (car key)) (val (configf:lookup test-conf "test_meta" fld))) ;; (debug:print 5 *default-log-port* "idx: " idx " fld: " fld " val: " val) (if (and val (not (equal? (vector-ref currrecord idx) val))) (begin (debug:print 2 *default-log-port* "Updating " test-name " " fld " to " val) (rmt:testmeta-update-field test-name fld val))))) '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10))))) ;; find tests with matching tags, tagpatt is a string "tagpatt1,tagpatt2%, ..." ;; (define (runs:get-tests-matching-tags tagpatt) (let* ((tagdata (rmt:get-tests-tags)) |
︙ | ︙ | |||
3116 3117 3118 3119 3120 3121 3122 | (let* ((linktree (common:get-linktree)) ;; (if toppath (configf:lookup *configdat* "setup" "linktree"))) (runtop (conc linktree "/" target "/" runname)) (files (if (common:file-exists? runtop) (append (glob (conc runtop "/.megatest*")) (glob (conc runtop "/.runconfig*"))) '()))) (if (null? files) | | | | 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 | (let* ((linktree (common:get-linktree)) ;; (if toppath (configf:lookup *configdat* "setup" "linktree"))) (runtop (conc linktree "/" target "/" runname)) (files (if (common:file-exists? runtop) (append (glob (conc runtop "/.megatest*")) (glob (conc runtop "/.runconfig*"))) '()))) (if (null? files) (debug:print-info 2 *default-log-port* "No cached megatest or runconfigs files found. None removed.") (begin (debug:print-info 2 *default-log-port* "Removing cached files:\n " (string-intersperse files "\n ")) (for-each (lambda (f) (handle-exceptions exn (debug:print 0 *default-log-port* "WARNING: Failed to remove file " f ", exn=" exn) (delete-file f))) files)))) (debug:print-error 0 *default-log-port* "-clean-cache requires -runname.")) (debug:print-error 0 *default-log-port* "-clean-cache requires -target or -reqtarg"))) |
Modified server.scm from [8697088094] to [c559be1916].
︙ | ︙ | |||
12 13 14 15 16 17 18 | ;; 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/>. ;; | < | < < < < | | < > > > > > > > > > > | 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 | ;; 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 server)) (declare (uses commonmod)) (declare (uses debugprint)) (declare (uses common)) (declare (uses db)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. ;; (declare (uses synchash)) ;;(declare (uses rpc-transport)) (declare (uses launch)) ;; (declare (uses daemon)) (declare (uses mtargs)) (use (srfi 18) extras s11n) (use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) (use directory-utils posix-extras matchable utils) (use spiffy uri-common intarweb http-client spiffy-request-vars) (import commonmod debugprint (prefix mtargs args:)) (include "common_records.scm") (include "db_records.scm") (define (server:make-server-url hostport) (if (not hostport) #f |
︙ | ︙ | |||
59 60 61 62 63 64 65 | ;;====================================================================== ;; S E R V E R ;;====================================================================== ;; Call this to start the actual server ;; | < < < < < < < < < < < | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 | ;;====================================================================== ;; S E R V E R ;;====================================================================== ;; Call this to start the actual server ;; ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== ;; Get the transport (define (server:get-transport) (if *transport-type* |
︙ | ︙ | |||
91 92 93 94 95 96 97 98 99 | ;; Generate a unique signature for this server (define (server:mk-signature) (message-digest-string (md5-primitive) (with-output-to-string (lambda () (write (list (current-directory) (argv))))))) | > > > > > > > > > > > > > | | | | | | | | | | | | | | | | < < < < < < < | > | | | | | | | | | | | | | | < | | > > > | | > > > | | > > | | | | | | | | | > > | | | < > > > | > | | | > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | > > > > > | | | > > | > | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | < | | | < < < < < < < < < < | > > > | | > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > | > > > > > > > | | > > | > > > > > > > > > | > > > > | > | | | | > > > > > > > > | < < < < < < < < < | < | | > | | | | < > | | | > | | < < | | < | | | | | | < < > > > > > | | | | | | | | < < < < < < < < | | | | | | > | | < | < | < < < > | | | | > | | | | | | | | | > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | > | > > | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < < < < < < < < < < < < | < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 | ;; Generate a unique signature for this server (define (server:mk-signature) (message-digest-string (md5-primitive) (with-output-to-string (lambda () (write (list (current-directory) (current-process-id) (argv))))))) (define (server:get-client-signature) (if *my-client-signature* *my-client-signature* (let ((sig (server:mk-signature))) ;; clients re-use the server:mk-signature logic (set! *my-client-signature* sig) *my-client-signature*))) (define (server:get-server-id) (if *server-id* *server-id* (let ((sig (server:mk-signature))) ;; clients re-use the server:mk-signature logic (set! *server-id* sig) *server-id*))) ;; ;; When using zmq this would send the message back (two step process) ;; ;; with spiffy or rpc this simply returns the return data to be returned ;; ;; ;; (define (server:reply return-addr query-sig success/fail result) ;; (debug:print-info 11 *default-log-port* "server:reply return-addr=" return-addr ", result=" result) ;; ;; (send-message pubsock target send-more: #t) ;; ;; (send-message pubsock ;; (case (server:get-transport) ;; ((rpc) (db:obj->string (vector success/fail query-sig result))) ;; ((http) (db:obj->string (vector success/fail query-sig result))) ;; ((fs) result) ;; (else ;; (debug:print-error 0 *default-log-port* "unrecognised transport type: " *transport-type*) ;; result))) ;; Given an area path, start a server process ### NOTE ### > file 2>&1 ;; if the target-host is set ;; try running on that host ;; incidental: rotate logs in logs/ dir. ;; (define (server:run areapath) ;; areapath is *toppath* for a given testsuite area (let* ((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")) ;; why are we rotating logs here? This is a sensitive location with a lot going on!? (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) ;; host.domain.tld match host? ;; (if (and target-host ;; ;; look at target host, is it host.domain.tld or ip address and does it ;; ;; match current ip or hostname ;; (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host)) ;; (not (equal? curr-ip target-host))) ;; (begin ;; (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile) ;; (setenv "TARGETHOST" target-host))) ;; (setenv "TARGETHOST_LOGF" logfile) (thread-sleep! (/ (random 3000) 1000)) ;; add a random initial delay. It seems pretty common that many running tests request a server at the same time (debug:print 0 *default-log-port* "INFO: starting server at " (common:human-time)) (system (conc "nbfake " cmdln)) (unsetenv "TARGETHOST_LOGF") ;; (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST")) (thread-join! log-rotate) (pop-directory))) ;; given a path to a server log return: host port startseconds server-id ;; any changes to number of elements returned by this fuction will dirctly affect server:record->url,server:record->id,server:kill,server:get-num-alive which use match let ;; example of what it's looking for in the log file: ;; SERVER STARTED: 10.38.175.67:50216 AT 1616502350.0 server-id: 4907e90fc55c7a09694e3f658c639cf4 (define (server:logf-get-start-info logf) (let ((server-rx (regexp "^SERVER STARTED: (\\S+):(\\d+) AT ([\\d\\.]+) server-id: (\\S+) pid: (\\d+)")) ;; SERVER STARTED: host:port AT timesecs server id (dbprep-rx (regexp "^SERVER: dbprep")) (dbprep-found 0) (bad-dat (list #f #f #f #f #f))) (handle-exceptions exn (begin ;; WARNING: this is potentially dangerous to blanket ignore the errors (if (file-exists? logf) (debug:print-info 2 *default-log-port* "Unable to get server info from "logf", exn=" exn)) bad-dat) ;; no idea what went wrong, call it a bad server (with-input-from-file logf (lambda () (let loop ((inl (read-line)) (lnum 0)) (if (not (eof-object? inl)) (let ((mlst (string-match server-rx inl)) (dbprep (string-match dbprep-rx inl))) (if dbprep (set! dbprep-found 1)) (if (not mlst) (if (< lnum 500) ;; give up if more than 500 lines of server log read (loop (read-line)(+ lnum 1)) (begin (debug:print-info 0 *default-log-port* "Unable to get server info from first 500 lines of " logf ) bad-dat)) (match mlst ((_ host port start server-id pid) (list host (string->number port) (string->number start) server-id (string->number pid))) (else (debug:print 0 *current-log-port* "ERROR: did not recognise SERVER line info "mlst) bad-dat)))) (begin (if dbprep-found (begin (debug:print-info 2 *default-log-port* "Server is in dbprep at " (common:human-time)) (thread-sleep! 0.5)) ;; was 25 sec but that blocked things from starting? (debug:print-info 0 *default-log-port* "Unable to get server info from " logf " at " (seconds->time-string (current-seconds)))) bad-dat)))))))) ;; ;; get a list of servers from the log files, with all relevant data ;; ;; ( mod-time host port start-time pid ) ;; ;; ;; (define (server:get-list areapath #!key (limit #f)) ;; (let ((fname-rx (regexp "^(|.*/)server-(\\d+)-(\\S+).log$")) ;; (day-seconds (* 24 60 60))) ;; ;; if the directory exists continue to get the list ;; ;; otherwise attempt to create the logs dir and then ;; ;; continue ;; (if (if (directory-exists? (conc areapath "/logs")) ;; '() ;; (if (file-write-access? areapath) ;; (begin ;; (condition-case ;; (create-directory (conc areapath "/logs") #t) ;; (exn (i/o file)(debug:print 0 *default-log-port* "ERROR: Cannot create directory at " (conc areapath "/logs"))) ;; (exn ()(debug:print 0 *default-log-port* "ERROR: Unknown error attemtping to get server list. exn=" exn))) ;; (directory-exists? (conc areapath "/logs"))) ;; '())) ;; ;; ;; Get the list of server logs. ;; (let* ( ;; ;; For some reason, when I uncomment the below line, ext-tests sometimes starts 1000's of servers. ;; ;; (exiting-servers (system (conc "bash -c 'rm -f `grep -il exiting " areapath "/logs/server-*-*.log 2> /dev/null`'"))) ;; (server-logs (glob (conc areapath "/logs/server-*-*.log"))) ;; (num-serv-logs (length server-logs))) ;; (if (or (null? server-logs) (= num-serv-logs 0)) ;; (let () ;; (debug:print 2 *default-log-port* "There are no servers running at " (common:human-time)) ;; '() ;; ) ;; (let loop ((hed (string-chomp (car server-logs))) ;; (tal (cdr server-logs)) ;; (res '())) ;; (let* ((mod-time (handle-exceptions ;; exn ;; (begin ;; (debug:print 0 *default-log-port* "server:get-list: failed to get modification time on " hed ", exn=" exn) ;; (current-seconds)) ;; 0 ;; (file-modification-time hed))) ;; default to *very* old so log gets ignored if deleted ;; (down-time (- (current-seconds) mod-time)) ;; (serv-dat (if (or (< num-serv-logs 10) ;; (< down-time 900)) ;; day-seconds)) ;; (server:logf-get-start-info hed) ;; '())) ;; don't waste time processing server files not touched in the 15 minutes if there are more than ten servers to look at ;; (serv-rec (cons mod-time serv-dat)) ;; (fmatch (string-match fname-rx hed)) ;; (pid (if fmatch (string->number (list-ref fmatch 2)) #f)) ;; (new-res (if (null? serv-dat) ;; res ;; (cons (append serv-rec (list pid)) res)))) ;; any changes to number of elements in new-res will dirctly affect server:record->url,server:record->id,server:kill,server:get-num-alive which uses match let ;; (if (null? tal) ;; (if (and limit ;; (> (length new-res) limit)) ;; new-res ;; (take new-res limit) <= need intelligent sorting before this will work ;; new-res) ;; (loop (string-chomp (car tal)) (cdr tal) new-res))))))))) #;(define (server:get-num-alive srvlst) (let ((num-alive 0)) (for-each (lambda (server) (handle-exceptions exn (begin (debug:print-info 0 *default-log-port* "Unable to get server start-time and/or mod-time from " server ", exn=" exn)) (match-let (((mod-time host port start-time server-id pid) server)) (let* ((uptime (- (current-seconds) mod-time)) (runtime (if start-time (- mod-time start-time) 0))) (if (< uptime 5)(set! num-alive (+ num-alive 1))))))) srvlst) num-alive)) ;; ;; given a list of servers get a list of valid servers, i.e. at least ;; ;; 10 seconds old, has started and is less than 1 hour old and is ;; ;; active (i.e. mod-time < 10 seconds ;; ;; ;; ;; mod-time host port start-time pid ;; ;; ;; ;; sort by start-time descending. I.e. get the oldest first. Young servers will thus drop off ;; ;; and servers should stick around for about two hours or so. ;; ;; ;; (define (server:get-best srvlst) ;; (let* ((nums (server:get-num-servers)) ;; (now (current-seconds)) ;; (slst (sort ;; (filter (lambda (rec) ;; (if (and (list? rec) ;; (> (length rec) 2)) ;; (let ((start-time (list-ref rec 3)) ;; (mod-time (list-ref rec 0))) ;; ;; (print "start-time: " start-time " mod-time: " mod-time) ;; (and start-time mod-time ;; (> (- now start-time) 0) ;; been running at least 0 seconds ;; (< (- now mod-time) 16) ;; still alive - file touched in last 16 seconds ;; (or (not (configf:lookup *configdat* "server" "runtime")) ;; skip if not set ;; (< (- now start-time) ;; (+ (- (string->number (configf:lookup *configdat* "server" "runtime")) ;; 180) ;; (random 360)))) ;; under one hour running time +/- 180 ;; )) ;; #f)) ;; srvlst) ;; (lambda (a b) ;; (< (list-ref a 3) ;; (list-ref b 3)))))) ;; (if (> (length slst) nums) ;; (take slst nums) ;; slst))) ;; ;; switch from server:get-list to server:get-servers-info ;; ;; ;; (define (server:get-first-best areapath) ;; (let ((srvrs (server:get-best (server:get-list areapath)))) ;; (if (and srvrs ;; (not (null? srvrs))) ;; (car srvrs) ;; #f))) ;; ;; (define (server:get-rand-best areapath) ;; (let ((srvrs (server:get-best (server:get-list areapath)))) ;; (if (and (list? srvrs) ;; (not (null? srvrs))) ;; (let* ((len (length srvrs)) ;; (idx (random len))) ;; (list-ref srvrs idx)) ;; #f))) (define (server:record->id servr) (handle-exceptions exn (begin (debug:print-info 0 *default-log-port* "Unable to get server id from " servr ", exn=" exn) #f) (match-let (((host port start-time server-id pid) servr)) (if server-id server-id #f)))) (define (server:record->url servr) (handle-exceptions exn (begin (debug:print-info 0 *default-log-port* "Unable to get server url from " servr ", exn=" exn) #f) (match-let (((host port start-time server-id pid) servr)) (if (and host port) (conc host ":" port) #f)))) ;; if server-start-last exists, and wasn't old enough, wait <idle time> + 1, then call this function recursively until it is old enough. ;; if it is old enough, overwrite it and wait 0.25 seconds. ;; if it then has the wrong server key, wait <idle time> + 1 and call this function recursively. ;; #;(define (server:wait-for-server-start-last-flag areapath) (let* ((start-flag (conc areapath "/logs/server-start-last")) ;;; THIS INTERACTS WITH [server] timeout. Suggest using 0.1 or above for timeout (6 seconds) (idletime (configf:lookup-number *configdat* "server" "idletime" default: 4)) (server-key (conc (get-host-name) "-" (current-process-id)))) (if (file-exists? start-flag) (let* ((fmodtime (file-modification-time start-flag)) (delta (- (current-seconds) fmodtime)) (old-enough (> delta idletime)) (new-server-key "")) ;; write start-flag file, wait 0.25s, then if previously the start-flag file was older than <idletime> seconds, and the new file still has the same server key as you just wrote, return #t. ;; the intention is to make sure nfs can read the file we just wrote, and make sure it was written by us, and not another process. (if (and old-enough (begin (debug:print-info 2 *default-log-port* "Writing " start-flag) (with-output-to-file start-flag (lambda () (print server-key))) (thread-sleep! 0.25) (set! new-server-key (with-input-from-file start-flag (lambda () (read-line)))) (equal? server-key new-server-key))) #t ;; If either of the above conditions is not true, print a "Gating server start" message, wait <idle-time> + 1, then call this function recursively. (begin (debug:print-info 2 *default-log-port* "Gating server start, last start: " (seconds->time-string fmodtime) ", time since last start: " delta ", required idletime: " idletime ", gating reason:" (if old-enough "another job started a server" "too soon to start another server")) (thread-sleep! ( + 1 idletime)) (server:wait-for-server-start-last-flag areapath))))))) ;; oldest server alive determines host then choose random of youngest ;; five servers on that host ;; (define (server:get-servers-info areapath) ;; (assert *toppath* "FATAL: server:get-servers-info called before *toppath* has been set.") (let* ((servinfodir (server:get-servinfo-dir areapath))) ;; (conc *toppath*"/.servinfo"))) (if (not (file-exists? servinfodir)) (create-directory servinfodir)) (let* ((allfiles (glob (conc servinfodir"/*"))) (res (make-hash-table))) (for-each (lambda (f) (let* ((hostport (pathname-strip-directory f)) (serverdat (server:logf-get-start-info f))) (match serverdat ((host port start server-id pid) (if (and host port start server-id pid) (hash-table-set! res hostport serverdat) (debug:print-info 2 *default-log-port* "bad server info for "f": "serverdat))) (else (debug:print-info 2 *default-log-port* "bad server info for "f": "serverdat))))) allfiles) res))) ;; check the .servinfo directory, are there other servers running on this ;; or another host? ;; ;; returns #t => ok to start another server ;; #f => not ok to start another server ;; (define (server:minimal-check areapath) (server:clean-up-old areapath) (let* ((srvdir (server:get-servinfo-dir areapath)) ;; (conc areapath"/.servinfo")) (servrs (glob (conc srvdir"/*"))) (thishostip (server:get-best-guess-address (get-host-name))) (thisservrs (glob (conc srvdir"/"thishostip":*"))) (homehostinf (server:choose-server areapath 'homehost)) (havehome (car homehostinf)) (wearehome (cdr homehostinf))) (debug:print-info 0 *default-log-port* thishostip", have homehost: "havehome", we are homehost: "wearehome ", numservers: "(length thisservrs)) (cond ((not havehome) #t) ;; no homehost yet, go for it ((and havehome wearehome (< (length thisservrs) 20)) #t) ;; we are home and less than 20 servers, ok to start another ((and havehome (not wearehome)) #f) ;; we are not the home host ((and havehome wearehome (>= (length thisservrs) 20)) #f) ;; have enough running (else (debug:print 0 *default-log-port* "WARNING: Unrecognised scenario, servrs="servrs", thishostip="thishostip", thisservrs="thisservrs) #t)))) (define server-last-start 0) ;; oldest server alive determines host then choose random of youngest ;; five servers on that host ;; ;; mode: ;; best - get best server (random of newest five) ;; home - get home host based on oldest server ;; info - print info (define (server:choose-server areapath #!optional (mode 'best)) ;; age is current-starttime ;; find oldest alive ;; 1. sort by age ascending and ping until good ;; find alive rand from youngest ;; 1. sort by age descending ;; 2. take five ;; 3. check alive, discard if not and repeat ;; first we clean up old server files (assert (eq? (rmt:transport-mode) 'http) "FATAL: server:run called with rmt:transport-mode="(rmt:transport-mode)) (server:clean-up-old areapath) (let* ((since-last (- (current-seconds) server-last-start)) (server-start-delay 10)) (if ( < (- (current-seconds) server-last-start) 10 ) (begin (debug:print 2 *default-log-port* "server:choose-server: seconds since last server start: " (- (current-seconds) server-last-start)) (debug:print 2 *default-log-port* "server:choose-server: last server start less than " server-start-delay " seconds ago. Sleeping " server-start-delay " seconds") (thread-sleep! server-start-delay) ) (debug:print 2 *default-log-port* "server:choose-server: seconds since last server start: " (- (current-seconds) server-last-start)) ) ) (let* ((serversdat (server:get-servers-info areapath)) (servkeys (hash-table-keys serversdat)) (by-time-asc (if (not (null? servkeys)) ;; NOTE: Oldest is last (sort servkeys ;; list of "host:port" (lambda (a b) (>= (list-ref (hash-table-ref serversdat a) 2) (list-ref (hash-table-ref serversdat b) 2)))) '()))) (debug:print 2 *default-log-port* "server:choose-server: serversdat: " serversdat) (debug:print 2 *default-log-port* "server:choose-server: servkeys: " servkeys) (if (not (null? by-time-asc)) (let* ((oldest (last by-time-asc)) (oldest-dat (hash-table-ref serversdat oldest)) (host (list-ref oldest-dat 0)) (all-valid (filter (lambda (x) (equal? host (list-ref (hash-table-ref serversdat x) 0))) by-time-asc)) (best-ten (lambda () (if (> (length all-valid) 11) (take (drop-right all-valid 1) 10) ;; remove the oldest from consideration so it can age out (if (> (length all-valid) 8) (drop-right all-valid 1) all-valid)))) (names->dats (lambda (names) (map (lambda (x) (hash-table-ref serversdat x)) names))) (am-home? (lambda () (let* ((currhost (get-host-name)) (bestadrs (server:get-best-guess-address currhost))) (or (equal? host currhost) (equal? host bestadrs)))))) (case mode ((info) (debug:print 0 *default-log-port* "oldest: "oldest-dat", selected host: "host", all-valid: "all-valid) (debug:print 0 *default-log-port* "youngest: "(hash-table-ref serversdat (car all-valid)))) ((home) host) ((homehost) (cons host (am-home?))) ;; shut up old code ((home?) (am-home?)) ((best-ten)(names->dats (best-ten))) ((all-valid)(names->dats all-valid)) ((best) (let* ((best-ten (best-ten)) (len (length best-ten))) (hash-table-ref serversdat (list-ref best-ten (random len))))) ((count)(length all-valid)) (else (debug:print 0 *default-log-port* "ERROR: invalid command "mode) #f))) (begin (server:run areapath) (set! server-last-start (current-seconds)) ;; (thread-sleep! 3) (case mode ((homehost) (cons #f #f)) (else #f)))))) (define (server:get-servinfo-dir areapath) (let* ((spath (conc areapath"/.servinfo"))) (if (not (file-exists? spath)) (create-directory spath #t)) spath)) (define (server:clean-up-old areapath) ;; any server file that has not been touched in ten minutes is effectively dead (let* ((sfiles (glob (conc (server:get-servinfo-dir areapath)"/*")))) (for-each (lambda (sfile) (let* ((modtime (handle-exceptions exn (begin (debug:print 0 *default-log-port* "WARNING: failed to get modification file for "sfile) (current-seconds)) (file-modification-time sfile)))) (if (and (number? modtime) (> (- (current-seconds) modtime) 600)) (begin (debug:print 0 *default-log-port* "WARNING: found old server info file "sfile", removing it.") (handle-exceptions exn (debug:print 0 *default-log-port* "WARNING: failed to delete old server info file "sfile) (delete-file sfile)))))) sfiles))) ;; would like to eventually get rid of this ;; (define (common:on-homehost?) (if (eq? (rmt:transport-mode) 'http) (server:choose-server *toppath* 'home?) #t)) ;; there is no homehost for tcp and nfs is always on home so #t should work ;; kind start up of server, wait before allowing another server for a given ;; area to be launched ;; (define (server:kind-run areapath) ;; look for $MT_RUN_AREA_HOME/logs/server-start-last ;; and wait for it to be at least <server idletime> seconds old ;; (server:wait-for-server-start-last-flag areapath) (let loop () (if (> (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f)) 2) (begin (if (common:low-noise-print 30 "our-host-load") (debug:print 0 *default-log-port* "WARNING: system load is high, waiting to start server.")) (loop)))) (if (< (server:choose-server areapath 'count) 20) (server:run areapath)) #;(if (not (server:check-if-running areapath)) ;; why try if there is already a server running? (let* ((lock-file (conc areapath "/logs/server-start.lock"))) (let* ((start-flag (conc areapath "/logs/server-start-last"))) (common:simple-file-lock-and-wait lock-file expire-time: 25) (debug:print-info 2 *default-log-port* "server:kind-run: touching " start-flag) (system (conc "touch " start-flag)) ;; lazy but safe (server:run areapath) (thread-sleep! 20) ;; don't release the lock for at least a few seconds. And allow time for the server startup to get to "SERVER STARTED". (common:simple-file-release-lock lock-file))) (debug:print-info 0 *default-log-port* "Found server already running. NOT trying to start another."))) ;; this one seems to be the general entry point ;; (define (server:start-and-wait areapath #!key (timeout 60)) (let ((give-up-time (+ (current-seconds) timeout))) (let loop ((server-info (server:check-if-running areapath)) (try-num 0)) (if (or server-info (> (current-seconds) give-up-time)) ;; server-url will be #f if no server available. (server:record->url server-info) (let* ( (servers (server:choose-server areapath 'all-valid)) (num-ok (if servers (length (server:choose-server areapath 'all-valid)) 0))) (if (and (> try-num 0) ;; first time through simply wait a little while then try again (< num-ok 1)) ;; if there are no decent candidates for servers then try starting a new one (server:run areapath)) (thread-sleep! 5) (loop (server:check-if-running areapath) (+ try-num 1))))))) (define (server:get-num-servers #!key (numservers 2)) (let ((ns (string->number (or (configf:lookup *configdat* "server" "numservers") "notanumber")))) (or ns numservers))) ;; no longer care if multiple servers are started by accident. older servers will drop off in time. ;; (define (server:check-if-running areapath) ;; #!key (numservers "2")) (let* ((ns (server:get-num-servers)) ;; get the setting the for maximum number of servers allowed (servers (server:choose-server areapath 'best-ten))) ;; (server:get-best (server:get-list areapath)))) (if (or (and servers (null? servers)) (not servers)) ;; (and (list? servers) ;; (< (length servers) (+ 1 (random ns))))) ;; somewhere between 1 and numservers #f (let loop ((hed (car servers)) (tal (cdr servers))) (let ((res (server:check-server hed))) (if res hed (if (null? tal) #f (loop (car tal)(cdr tal))))))))) ;; ping the given server ;; (define (server:check-server server-record) (let* ((server-url (server:record->url server-record)) (server-id (server:record->id server-record)) (res (server:ping server-url server-id))) (if res server-url #f))) (define (server:kill servr) (handle-exceptions exn (begin (debug:print-info 0 *default-log-port* "Unable to get host and/or port from " servr ", exn=" exn) #f) (match-let (((hostname port start-time server-id pid) servr)) (tasks:kill-server hostname pid)))) ;; ;; called in megatest.scm, host-port is string hostname:port ;; ;; ;; ;; NOTE: This is NOT called directly from clients as not all transports support a client running ;; ;; in the same process as the server. ;; ;; ;; (define (server:ping host:port server-id #!key (do-exit #f)) ;; (let* ((host-port (cond ;; ((string? host:port) ;; (let ((slst (string-split host:port ":"))) ;; (if (eq? (length slst) 2) ;; (list (car slst)(string->number (cadr slst))) ;; #f))) ;; (else ;; #f)))) ;; (cond ;; ((and (list? host-port) ;; (eq? (length host-port) 2)) ;; (let* ((myrunremote (make-and-init-remote *toppath*)) ;; (iface (car host-port)) ;; (port (cadr host-port)) ;; (server-dat (client:connect iface port server-id myrunremote)) ;; (login-res (rmt:login-no-auto-client-setup myrunremote))) ;; (http-transport:close-connections myrunremote) ;; (if (and (list? login-res) ;; (car login-res)) ;; (begin ;; ;; (print "LOGIN_OK") ;; (if do-exit (exit 0)) ;; #t) ;; (begin ;; ;; (print "LOGIN_FAILED") ;; (if do-exit (exit 1)) ;; #f)))) ;; (else ;; (if host:port ;; (debug:print 0 *default-log-port* "ERROR: bad host:port "host:port)) ;; (if do-exit ;; (exit 1) ;; #f))))) ;; ;; ;; run ping in separate process, safest way in some cases ;; ;; ;; (define (server:ping-server ifaceport) ;; (with-input-from-pipe ;; (conc (common:get-megatest-exe) " -ping " ifaceport) ;; (lambda () ;; (let loop ((inl (read-line)) ;; (res "NOREPLY")) ;; (if (eof-object? inl) ;; (case (string->symbol res) ;; ((NOREPLY) #f) ;; ((LOGIN_OK) #t) ;; (else #f)) ;; (loop (read-line) inl)))))) ;; ;; ;; NOT USED (well, ok, reference in rpc-transport but otherwise not used). ;; ;; ;; (define (server:login toppath) ;; (lambda (toppath) ;; (set! *db-last-access* (current-seconds)) ;; might not be needed. ;; (if (equal? *toppath* toppath) ;; #t ;; #f))) ;; timeout is hms string: 1h 5m 3s, default is 1 minute ;; This is currently broken. Just use the number of hours with no unit. ;; Default is 600 seconds. ;; (define (server:expiration-timeout) (let* ((tmo (configf:lookup *configdat* "server" "timeout"))) (if (string? tmo) (let* ((num (string->number tmo))) (if num (* 3600 num) (common:hms-string->seconds tmo))) 600 ;; this is the default ))) (define (server:get-best-guess-address hostname) (let ((res #f)) (for-each (lambda (adr) (if (not (eq? (u8vector-ref adr 0) 127)) (set! res adr))) ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME (vector->list (hostinfo-addresses (hostname->hostinfo hostname)))) (string-intersperse (map number->string (u8vector->list (if res res (hostname->ip hostname)))) "."))) ;; moving this here as it needs access to db and cannot be in common. ;; (define (server:get-bruteforce-syncer dbstruct #!key (fork-to-background #f) (persist-until-sync #f)) (debug:print "WARNING: bruteforce-syncer is called but has been disabled!") (lambda () (debug:print "WARNING: bruteforce-syncer is called but has been disabled!"))) |
Modified spublish.scm from [d0bcfc709c] to [ec4585c620].
︙ | ︙ | |||
394 395 396 397 398 399 400 | (sauth:print-error (conc "Source path " src-path " does not exist!!" ))) (else (if (< (sauth-common:space-left-at-dest target-path) (sauth-common:src-size src-path)) (begin (sauth:print-error "Destination does not have enough disk space.") (exit 1))) (if (is_directory src-path) | | | | | | | | | | | 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 | (sauth:print-error (conc "Source path " src-path " does not exist!!" ))) (else (if (< (sauth-common:space-left-at-dest target-path) (sauth-common:src-size src-path)) (begin (sauth:print-error "Destination does not have enough disk space.") (exit 1))) (if (is_directory src-path) (begin (let* ((parent-dir src-path) (start-dir target-path)) (run (pipe (begin (system (conc "cd " parent-dir " ;tar chf - ." ))) (begin (change-directory start-dir) ;(print "123") (run-cmd "tar" (list "xf" "-"))))) (print "Copied data to " start-dir))) (begin (let*((parent-dir (pathname-directory src-path)) (start-dir target-path) (filename (if (pathname-extension src-path) (conc(pathname-file src-path) "." (pathname-extension src-path)) (pathname-file src-path)))) ;(print "parent-dir " parent-dir " start-dir " start-dir) |
︙ | ︙ |
Modified sretrieve.scm from [15a6ca2860] to [bc076b5abf].
︙ | ︙ | |||
635 636 637 638 639 640 641 | (let* ((parent-dir target-path) (last-dir-name (if (pathname-extension target-path) (conc(pathname-file target-path) "." (pathname-extension target-path)) (pathname-file target-path))) (curr-dir (current-directory)) (start-dir (conc (current-directory) "/" last-dir-name)) (execlude (make-exclude-pattern (string-split restrictions ","))) | | < | | | | 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 | (let* ((parent-dir target-path) (last-dir-name (if (pathname-extension target-path) (conc(pathname-file target-path) "." (pathname-extension target-path)) (pathname-file target-path))) (curr-dir (current-directory)) (start-dir (conc (current-directory) "/" last-dir-name)) (execlude (make-exclude-pattern (string-split restrictions ","))) (tmpfile (conc "/tmp/my-pipe-" (current-process-id)))) (if (file-exists? start-dir) (begin (sauth:print-error (conclast-dir-name " already exist in your work dir.")) (sauth:print-error "Nothing has been retrieved!! ")) (begin ; (sretrieve:do-as-calling-user ; (lambda () ; (print tmpfile) ;(if (not (file-exists? (conc "/tmp/" (current-user-name)))) ; (create-directory (conc "/tmp/" (current-user-name)) #t)) (change-directory parent-dir) (create-fifo tmpfile) (process-fork (lambda() (sleep 1) (with-output-to-file tmpfile (lambda () |
︙ | ︙ | |||
696 697 698 699 700 701 702 | (print (string-substitute (conc base_path "/") "" p "-")))) ((directory? p) ;;do nothing for dirs) ) (else (if (not (string-match (regexp exclude) p )) | | > | 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 | (print (string-substitute (conc base_path "/") "" p "-")))) ((directory? p) ;;do nothing for dirs) ) (else (if (not (string-match (regexp exclude) p )) (print (string-substitute (conc base_path "/") "" p "-")))))) dotfiles: #t)) (define (sretrieve:shell-help) (conc "Usage: " *exe-name* " [action [params ...]] ls [target path] : list contents of target area. The output of the cmd can be piped into other system cmd. eg ls <path> | grep txt cd <target directory> : To change the current directory within the sretrive shell. pwd : Prints the full pathname of the current directory within the sretrive shell. |
︙ | ︙ | |||
1080 1081 1082 1083 1084 1085 1086 | (else (print 0 "Unrecognised command " action)))) (define (main) (let* ((args (argv)) (prog (car args)) (rema (cdr args)) (exe-name (pathname-file (car (argv)))) | | | | 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 | (else (print 0 "Unrecognised command " action)))) (define (main) (let* ((args (argv)) (prog (car args)) (rema (cdr args)) (exe-name (pathname-file (car (argv)))) ;(exe-dir (or (pathname-directory prog) ; (sretrieve:find exe-name (string-split (get-environment-variable "PATH") ":")))) ;(configdat (sretrieve:load-config exe-dir exe-name)) ) ;; preserve the exe data in the config file ;(hash-table-set! configdat "exe-info" (list (list "exe-name" exe-name) ; (list "exe-dir" exe-dir))) (cond ;; one-word commands |
︙ | ︙ |
Modified subrun.scm from [0aa479705e] to [aaf114f8dc].
︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 | ;; 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/>. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) posix-extras directory-utils pathname-expand typed-records format call-with-environment-variables) | > > > > > > > | < < | < < < < | < < | | < < | | 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 | ;; 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/>. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') (declare (unit subrun)) (declare (uses debugprint)) (declare (uses db)) (declare (uses common)) (declare (uses commonmod)) (declare (uses mt)) (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) posix-extras directory-utils pathname-expand typed-records format call-with-environment-variables) (import commonmod debugprint) ;(include "common_records.scm") ;;(include "key_records.scm") (include "db_records.scm") ;; provides db:test-get-id ;;(include "run_records.scm") ;;(include "test_records.scm") (define (subrun:subrun-test-initialized? test-run-dir) (if (and (common:file-exists? (conc test-run-dir "/subrun-area") ) (common:file-exists? (conc test-run-dir "/testconfig.subrun") )) #t #f)) (define (subrun:launch-dashboard test-run-dir) (if (subrun:subrun-test-initialized? test-run-dir) (let* ((subarea (subrun:get-runarea test-run-dir))) (if (and subarea (common:file-exists? subarea)) (system (conc "cd " subarea ";env -i PATH=\"$PATH\" DISPLAY=$DISPLAY HOME=$HOME USER=$USER dashboard &")))))) (define (subrun:subrun-removed? test-run-dir) (if (subrun:subrun-test-initialized? test-run-dir) (let ((flagfile (conc test-run-dir "/subrun.removed"))) (if (common:file-exists? flagfile) #t #f)) |
︙ | ︙ | |||
128 129 130 131 132 133 134 | (let* ((action-switches-str (conc "-kill-runs" )) (kill-result (subrun:exec-sub-megatest test-run-dir action-switches-str "kill"))) kill-result) #t)) | | | | | 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 | (let* ((action-switches-str (conc "-kill-runs" )) (kill-result (subrun:exec-sub-megatest test-run-dir action-switches-str "kill"))) kill-result) #t)) (define (subrun:launch-cmd test-run-dir run-mode #!optional (sub-cmd "-run")) ;; BUG: "-run" should be changed to "-rerun-clean" but current doesn't work (if (subrun:subrun-removed? test-run-dir) (subrun:unset-subrun-removed test-run-dir)) (let* ((log-prefix "run") (switches (subrun:selector+log-switches test-run-dir log-prefix)) (run-wait (equal? run-mode "yes")) (cmd (conc (common:get-mtexe)" "sub-cmd" "switches" " (if run-wait "-run-wait " "")))) cmd)) (define (subrun:sanitize-path inpath) (let* ((insane-pattern (irregex "[^[a-zA-Z0-9_\\-]"))) (regex#string-substitute insane-pattern "_" inpath #t))) |
︙ | ︙ | |||
209 210 211 212 213 214 215 | ;; swap out testpatt with modified test-patt and add -log (switch-alist (cons (cons "-log" logfile) (map (lambda (item) (if (equal? (car item) "-testpatt") (cons "-testpatt" testpatt) item)) | | < < < | 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 | ;; swap out testpatt with modified test-patt and add -log (switch-alist (cons (cons "-log" logfile) (map (lambda (item) (if (equal? (car item) "-testpatt") (cons "-testpatt" testpatt) item)) switch-alist-pre)))) switch-alist)) ;; note - get precmd from subrun section ;; apply to submegatest commands (define (subrun:get-log-path test-run-dir log-prefix) (let* ((alist (subrun:selector+log-alist test-run-dir log-prefix)) (res (alist-ref "-log" alist equal? #f))) |
︙ | ︙ | |||
235 236 237 238 239 240 241 242 | (map (lambda (x) (list (car x) (cdr x))) switch-alist)) " "))) res)) (define (subrun:exec-sub-megatest test-run-dir action-switches-str log-prefix) | > > > > | | | | 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 | (map (lambda (x) (list (car x) (cdr x))) switch-alist)) " "))) res)) ;; NOTE: Here we run sub megatest but this is not intended for one version ;; of megatest to test another version. Thus we propagate the (define (subrun:exec-sub-megatest test-run-dir action-switches-str log-prefix) (let* ((mtpathdir (common:get-megatest-exe-dir)) (mtexe (common:get-mtexe)) (selector-switches (subrun:selector+log-switches test-run-dir log-prefix)) (cmd (conc mtexe" "selector-switches" "action-switches-str )) (pid #f) (proc (lambda () (debug:print-info 0 *default-log-port* "Running sub megatest command: "cmd) ;;(set! pid (process-run "/usr/bin/xterm" (list )))))) (set! pid (process-run "/bin/bash" (list "-c" cmd)))))) (call-with-environment-variables (list (cons "PATH" (common:get-megatest-exe-path))) (lambda () (common:without-vars proc "^MT_.*"))) (let processloop ((i 0)) (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) (if (eq? pid-val 0) (begin (thread-sleep! 2) |
︙ | ︙ |
Modified tasks.scm from [e136a37772] to [93c938d59a].
︙ | ︙ | |||
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/>. ;; ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format) (import (prefix sqlite3 sqlite3:)) | > > > > > > > > > > > > > | | | < | > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 | ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') (declare (unit tasks)) (declare (uses debugprint)) (declare (uses dbfile)) (declare (uses db)) (declare (uses dbmod)) (declare (uses rmt)) (declare (uses rmtmod)) (declare (uses common)) (declare (uses pgdb)) (declare (uses commonmod)) (declare (uses mtargs)) (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format) (import (prefix sqlite3 sqlite3:)) (import commonmod debugprint dbmod rmtmod (prefix mtargs args:)) (import dbfile) ;; (import pgdb) ;; pgdb is a module (include "task_records.scm") (include "db_records.scm") ;;====================================================================== ;; Tasks db ;;====================================================================== (define (tasks:get-task-db-path) (let ((dbdir (or (configf:lookup *configdat* "setup" "monitordir") (configf:lookup *configdat* "setup" "dbdir") (conc (common:get-linktree) "/.db")))) (handle-exceptions exn (begin |
︙ | ︙ | |||
101 102 103 104 105 106 107 | (debug:print 5 *default-log-port* " exn=" (condition->list exn)) (thread-sleep! 1) (tasks:open-db numretries (- numretries 1))) (begin (print-call-chain (current-error-port)) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 5 *default-log-port* " exn=" (condition->list exn)))) | | | 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 | (debug:print 5 *default-log-port* " exn=" (condition->list exn)) (thread-sleep! 1) (tasks:open-db numretries (- numretries 1))) (begin (print-call-chain (current-error-port)) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 5 *default-log-port* " exn=" (condition->list exn)))) (let* ((dbpath (common:make-tmpdir-name *toppath* "")) ;; (tasks:get-task-db-path)) (dbfile (conc dbpath "/monitor.db")) (avail (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away (exists (common:file-exists? dbpath)) (write-access (file-write-access? dbpath)) (mdb (cond ;; what the hek is *toppath* doing here? ((and (string? *toppath*)(file-write-access? *toppath*)) (sqlite3:open-database dbfile)) |
︙ | ︙ | |||
251 252 253 254 255 256 257 | (define (tasks:monitors-update mdb) (sqlite3:execute mdb "UPDATE monitors SET last_update=strftime('%s','now') WHERE pid=? AND hostname=?;" (current-process-id) (get-host-name)) (let ((deadlist '())) (sqlite3:for-each-row (lambda (id pid host last-update delta) | | | | 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 | (define (tasks:monitors-update mdb) (sqlite3:execute mdb "UPDATE monitors SET last_update=strftime('%s','now') WHERE pid=? AND hostname=?;" (current-process-id) (get-host-name)) (let ((deadlist '())) (sqlite3:for-each-row (lambda (id pid host last-update delta) (debug:print 0 *default-log-port* "Going to delete stale record for monitor with pid " pid " on host " host " last updated " delta " seconds ago") (set! deadlist (cons id deadlist))) mdb "SELECT id,pid,hostname,last_update,strftime('%s','now')-last_update AS delta FROM monitors WHERE delta > 700;") (sqlite3:execute mdb (conc "DELETE FROM monitors WHERE id IN ('" (string-intersperse (map conc deadlist) "','") "');"))) ) (define (tasks:register-monitor db port) (let* ((pid (current-process-id)) (hostname (get-host-name)) (userinfo (user-information (current-user-id))) (username (car userinfo))) (debug:print 0 *default-log-port* "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username) (sqlite3:execute db "INSERT INTO monitors (pid,start_time,last_update,hostname,username) VALUES (?,strftime('%s','now'),strftime('%s','now'),?,?);" pid hostname username))) (define (tasks:get-num-alive-monitors mdb) (let ((res 0)) (sqlite3:for-each-row (lambda (count) |
︙ | ︙ | |||
325 326 327 328 329 330 331 | ;; execution_time TIMESTAMP); ;; register a task (define (tasks:add dbstruct action owner target runname testpatt params) (db:with-db dbstruct #f #t | | | 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 | ;; execution_time TIMESTAMP); ;; register a task (define (tasks:add dbstruct action owner target runname testpatt params) (db:with-db dbstruct #f #t (lambda (dbdat db) (sqlite3:execute db "INSERT INTO tasks_queue (action,owner,state,target,name,testpatt,params,creation_time,execution_time) VALUES (?,?,'new',?,?,?,?,strftime('%s','now'),0);" action owner target runname testpatt |
︙ | ︙ | |||
360 361 362 363 364 365 366 | ;; return one task from those who are 'new' OR 'waiting' AND more than 10sec old ;; (define (tasks:snag-a-task dbstruct) (let ((res #f) (keytxt (conc (current-process-id) "-" (get-host-name) "-" (car (user-information (current-user-id)))))) (db:with-db dbstruct #f #t | | | 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 | ;; return one task from those who are 'new' OR 'waiting' AND more than 10sec old ;; (define (tasks:snag-a-task dbstruct) (let ((res #f) (keytxt (conc (current-process-id) "-" (get-host-name) "-" (car (user-information (current-user-id)))))) (db:with-db dbstruct #f #t (lambda (dat db) ;; first randomly set a new to pid-hostname-hostname (sqlite3:execute db "UPDATE tasks_queue SET keylock=? WHERE id IN (SELECT id FROM tasks_queue WHERE state='new' OR (state='waiting' AND (strftime('%s','now')-execution_time) > 10) OR |
︙ | ︙ | |||
387 388 389 390 391 392 393 | res) #f))))) (define (tasks:reset-stuck-tasks dbstruct) (let ((res '())) (db:with-db dbstruct #f #t | | | | | | 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 | res) #f))))) (define (tasks:reset-stuck-tasks dbstruct) (let ((res '())) (db:with-db dbstruct #f #t (lambda (dat db) (sqlite3:for-each-row (lambda (id delta) (set! res (cons id res))) db "SELECT id,strftime('%s','now')-execution_time AS delta FROM tasks_queue WHERE state='inprogress' AND delta>700 ORDER BY delta DESC LIMIT 2;") (sqlite3:execute db (conc "UPDATE tasks_queue SET state='reset' WHERE id IN ('" (string-intersperse (map conc res) "','") "');") ))))) ;; return all tasks in the tasks_queue table ;; (define (tasks:get-tasks dbstruct types states) (let ((res '())) (db:with-db dbstruct #f #f (lambda (dbdat db) (sqlite3:for-each-row (lambda (id . rem) (set! res (cons (apply vector id rem) res))) db (conc "SELECT id,action,owner,state,target,name,test,item,params,creation_time,execution_time FROM tasks_queue " ;; WHERE ;; state IN " statesstr " AND ;; action IN " actionsstr " ORDER BY creation_time DESC;")) res)))) (define (tasks:get-last dbstruct target runname) (let ((res #f)) (db:with-db dbstruct #f #f (lambda (dbdat db) (sqlite3:for-each-row (lambda (id . rem) (set! res (apply vector id rem))) db (conc "SELECT id,action,owner,state,target,name,testpatt,keylock,params,creation_time,execution_time FROM tasks_queue WHERE target = ? AND name =? ORDER BY creation_time DESC LIMIT 1;") target runname) res)))) ;; remove tasks given by a string of numbers comma separated (define (tasks:remove-queue-entries dbstruct task-ids) (db:with-db dbstruct #f #t (lambda (dbdat db) (sqlite3:execute db (conc "DELETE FROM tasks_queue WHERE id IN (" task-ids ");"))))) ;; (define (tasks:process-queue dbstruct) ;; (let* ((task (tasks:snag-a-task dbstruct)) ;; (action (if task (tasks:task-get-action task) #f))) ;; (if action (print "tasks:process-queue task: " task)) ;; (if action |
︙ | ︙ | |||
475 476 477 478 479 480 481 | ;; (tasks:task-get-item task) (tasks:task-get-params task))) tasks) "\n")))) (define (tasks:set-state dbstruct task-id state) (db:with-db dbstruct #f #t | | | | | < < < | | > > | | | | | | | | 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 | ;; (tasks:task-get-item task) (tasks:task-get-params task))) tasks) "\n")))) (define (tasks:set-state dbstruct task-id state) (db:with-db dbstruct #f #t (lambda (dbdat db) (sqlite3:execute db "UPDATE tasks_queue SET state=? WHERE id=?;" state task-id)))) ;;====================================================================== ;; Access using task key (stored in params; (hash-table->alist flags) hostname pid ;;====================================================================== (define (tasks:param-key->id dbstruct task-params) (db:with-db dbstruct #f #f (lambda (dbdat db) (handle-exceptions exn #f (sqlite3:first-result db "SELECT id FROM tasks_queue WHERE params LIKE ?;" task-params))))) (define (tasks:set-state-given-param-key dbstruct param-key new-state) (db:with-db dbstruct #f #t (lambda (dbdat db) (sqlite3:execute db "UPDATE tasks_queue SET state=? WHERE params LIKE ?;" new-state param-key)))) (define (tasks:get-records-given-param-key dbstruct param-key state-patt action-patt test-patt) (db:with-db dbstruct #f #f (lambda (dbdat db) (handle-exceptions exn '() (sqlite3:first-row db "SELECT id,action,owner,state,target,name,testpatt,keylock,params WHERE params LIKE ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;" param-key state-patt action-patt test-patt))))) (define (tasks:find-task-queue-records dbstruct target run-name test-patt state-patt action-patt) (db:with-db dbstruct #f #f (lambda (dbdat db) (let ((res '())) (sqlite3:for-each-row (lambda (a . b) (set! res (cons (cons a b) res))) db "SELECT id,action,owner,state,target,name,testpatt,keylock,params FROM tasks_queue WHERE target = ? AND name = ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;" target run-name state-patt action-patt test-patt) res)))) ;; kill any runner processes (i.e. processes handling -runtests) that match target/runname ;; ;; do a remote call to get the task queue info but do the killing as self here. ;; (define (tasks:kill-runner target run-name testpatt) (let ((records (rmt:tasks-find-task-queue-records target run-name testpatt "running" "run-tests")) |
︙ | ︙ | |||
661 662 663 664 665 666 667 | (target-patt (if (args:get-arg "-target-patt") (args:get-arg "-target-patt") "%")) (run-times (rmt:get-run-times run-patt target-patt ))) (if (eq? (length run-times) 0) (begin | | | 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 | (target-patt (if (args:get-arg "-target-patt") (args:get-arg "-target-patt") "%")) (run-times (rmt:get-run-times run-patt target-patt ))) (if (eq? (length run-times) 0) (begin (debug:print 0 *default-log-port* "Data not found!!") (exit))) (if (equal? (args:get-arg "-dumpmode") "json") (task:print-runtime-as-json run-times) (if (equal? (args:get-arg "-dumpmode") "csv") (task:print-runtime run-times ",") (task:print-runtime run-times " "))))) |
︙ | ︙ | |||
707 708 709 710 711 712 713 | (target (if (args:get-arg "-target") (args:get-arg "-target") #f)) (test-times (rmt:get-test-times runname target ))) (if (not runname) (begin | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | (target (if (args:get-arg "-target") (args:get-arg "-target") #f)) (test-times (rmt:get-test-times runname target ))) (if (not runname) (begin (debug:print 0 *default-log-port* "Error: Missing argument -runname") (exit))) (if (string-contains runname "%") (begin (debug:print 0 *default-log-port* "Error: Invalid runname, '%' not allowed (" runname ") ") (exit))) (if (not target) (begin (debug:print 0 *default-log-port* "Error: Missing argument -target") (exit))) (if (string-contains target "%") (begin (debug:print 0 *default-log-port* "Error: Invalid target, '%' not allowed (" target ") ") (exit))) (if (eq? (length test-times) 0) (begin (debug:print 0 *default-log-port* "Data not found!!") (exit))) (if (equal? (args:get-arg "-dumpmode") "json") (task:print-testtime-as-json test-times) (if (equal? (args:get-arg "-dumpmode") "csv") (task:print-testtime test-times ",") (task:print-testtime test-times " "))))) ;; gets mtpg-run-id and syncs the record if different ;; (define (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time) (let* ((runs-ht (hash-table-ref cached-info 'runs)) (runinf (hash-table-ref/default runs-ht run-id #f)) (area-id (vector-ref area-info 0))) (if runinf runinf ;; already cached (let* ((run-dat (rmt:get-run-info run-id)) ;; NOTE: get-run-info returns a vector < row header > (run-name (rmt:get-run-name-from-id run-id)) (row (db:get-rows run-dat)) ;; yes, this returns a single row (header (db:get-header run-dat)) (state (db:get-value-by-header row header "state")) (status (db:get-value-by-header row header "status")) (owner (db:get-value-by-header row header "owner")) (event-time (db:get-value-by-header row header "event_time")) (comment (db:get-value-by-header row header "comment")) (fail-count (db:get-value-by-header row header "fail_count")) (pass-count (db:get-value-by-header row header "pass_count")) (db-contour (db:get-value-by-header row header "contour")) (contour (if (args:get-arg "-prepend-contour") (if (and db-contour (not (equal? db-contour "")) (string? db-contour )) (begin (debug:print-info 10 *default-log-port* "db-contour" db-contour) db-contour) (args:get-arg "-contour")))) (run-tag (if (args:get-arg "-run-tag") (args:get-arg "-run-tag") "")) (last-update (db:get-value-by-header row header "last_update")) (keytarg (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target")) (conc "MT_CONTOUR/MT_AREA/" (string-intersperse (rmt:get-keys) "/")) (string-intersperse (rmt:get-keys) "/"))) ;; e.g. version/iteration/platform (base-target (rmt:get-target run-id)) (target (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target")) (conc (or (args:get-arg "-prefix-target") (conc contour "/" (common:get-area-name) "/")) base-target) base-target)) ;; e.g. v1.63/a3e1/ubuntu (spec-id (pgdb:get-ttype dbh keytarg)) (publish-time (if (args:get-arg "-cp-eventtime-to-publishtime") event-time (current-seconds))) (new-run-id (if (and run-name base-target) (pgdb:get-run-id dbh spec-id target run-name area-id) #f))) (if new-run-id (begin ;; let ((run-record (pgdb:get-run-info dbh new-run-id)) (hash-table-set! runs-ht run-id new-run-id) ;; ensure key fields are up to date ;; if last_update == pgdb_last_update do not update smallest-last-update-time (let* ((pgdb-last-update (pgdb:get-run-last-update dbh new-run-id)) (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f))) (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time))) (hash-table-set! smallest-last-update-time "smallest-time" last-update))) (pgdb:refresh-run-info dbh new-run-id state status owner event-time comment fail-count pass-count area-id last-update publish-time) (debug:print-info 4 *default-log-port* (conc "Working on run-id " run-id " pgdb-id " new-run-id)) (if (not (equal? run-tag "")) (task:add-run-tag dbh new-run-id run-tag)) new-run-id) (if (or (not state) (equal? state "deleted")) (begin (debug:print-info 1 *default-log-port* "Warning: Run with id " run-id " was created after previous sync and deleted before the sync") #f) (if (handle-exceptions exn (begin (print-call-chain) (debug:print 0 *default-log-port* ((condition-property-accessor 'exn 'message) exn)) #f) (pgdb:insert-run dbh spec-id target run-name state status owner event-time comment fail-count pass-count area-id last-update publish-time)) (let* ((smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f))) (if (or (not smallest-time) (< last-update smallest-time)) (hash-table-set! smallest-last-update-time "smallest-time" last-update)) (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time)) #f))))))) (define (task:add-run-tag dbh run-id tag) (let* ((tag-info (pgdb:get-tag-info-by-name dbh tag))) (if (not tag-info) (begin (if (handle-exceptions exn |
︙ | ︙ | |||
834 835 836 837 838 839 840 | (if (not (pgdb:is-run-taged-with-a-tag dbh (vector-ref tag-info 0) run-id)) (pgdb:insert-run-tag dbh (vector-ref tag-info 0) run-id))))) (define (tasks:sync-test-steps dbh cached-info test-step-ids smallest-last-update-time) ; (print "Sync Steps " test-step-ids ) (let ((test-ht (hash-table-ref cached-info 'tests)) | | > > > > > > | | | | > > > > | | 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 | (if (not (pgdb:is-run-taged-with-a-tag dbh (vector-ref tag-info 0) run-id)) (pgdb:insert-run-tag dbh (vector-ref tag-info 0) run-id))))) (define (tasks:sync-test-steps dbh cached-info test-step-ids smallest-last-update-time) ; (print "Sync Steps " test-step-ids ) (let ((test-ht (hash-table-ref cached-info 'tests)) (step-ht (hash-table-ref cached-info 'steps)) (run-id-in #f) ) (for-each (lambda (test-step-id) (set! run-id-in (cdr test-step-id)) (set! test-step-id (car test-step-id)) (let* ((test-step-info (rmt:get-steps-info-by-id run-id-in test-step-id)) (step-id (tdb:step-get-id test-step-info)) (test-id (tdb:step-get-test_id test-step-info)) (stepname (tdb:step-get-stepname test-step-info)) (state (tdb:step-get-state test-step-info)) (status (tdb:step-get-status test-step-info)) (event_time (tdb:step-get-event_time test-step-info)) (comment (tdb:step-get-comment test-step-info)) (logfile (tdb:step-get-logfile test-step-info)) (last-update (tdb:step-get-last_update test-step-info)) (pgdb-test-id (hash-table-ref/default test-ht test-id #f)) (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f)) (pgdb-step-id (if pgdb-test-id (pgdb:get-test-step-id dbh pgdb-test-id stepname state) #f))) (if step-id (begin (if pgdb-test-id (begin (if pgdb-step-id (begin (debug:print-info 4 *default-log-port* "Updating existing test-step with test-id: " test-id " and step-id " step-id " pgdb test id: " pgdb-test-id " pgdb step id " pgdb-step-id ) (let* ((pgdb-last-update (pgdb:get-test-step-last-update dbh pgdb-step-id))) (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time))) (hash-table-set! smallest-last-update-time "smallest-time" last-update))) (pgdb:update-test-step dbh pgdb-step-id pgdb-test-id stepname state status event_time comment logfile last-update)) (begin (debug:print-info 4 *default-log-port* "Inserting test-step with test-id: " test-id " and step-id " step-id " pgdb test id: " pgdb-test-id) (if (or (not smallest-time) (< last-update smallest-time)) (hash-table-set! smallest-last-update-time "smallest-time" last-update)) (pgdb:insert-test-step dbh pgdb-test-id stepname state status event_time comment logfile last-update ) (set! pgdb-step-id (pgdb:get-test-step-id dbh pgdb-test-id stepname state)))) (hash-table-set! step-ht step-id pgdb-step-id )) (debug:print-info 1 *default-log-port* "Error: Test not cashed"))) (debug:print-info 1 *default-log-port* "Error: Could not get test step info for step id " test-step-id )))) ;; this is a wierd senario need to debug test-step-ids))) (define (tasks:sync-test-gen-data dbh cached-info test-data-ids smallest-last-update-time) (let ((test-ht (hash-table-ref cached-info 'tests)) (data-ht (hash-table-ref cached-info 'data)) (run-id-in #f) ) (for-each (lambda (test-data-id) (set! run-id-in (cdr test-data-id)) (set! test-data-id (car test-data-id)) (let* ((test-data-info (rmt:get-data-info-by-id run-id-in test-data-id)) (data-id (db:test-data-get-id test-data-info)) (test-id (db:test-data-get-test_id test-data-info)) (category (db:test-data-get-category test-data-info)) (variable (db:test-data-get-variable test-data-info)) (value (db:test-data-get-value test-data-info)) (expected (db:test-data-get-expected test-data-info)) (tol (db:test-data-get-tol test-data-info)) |
︙ | ︙ | |||
904 905 906 907 908 909 910 | #f))) (if data-id (begin (if pgdb-test-id (begin (if pgdb-data-id (begin | | | | | | > > > | > | | 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 | #f))) (if data-id (begin (if pgdb-test-id (begin (if pgdb-data-id (begin (debug:print-info 4 *default-log-port* "Updating existing test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id " pgdb data id " pgdb-data-id) (let* ((pgdb-last-update (pgdb:get-test-data-last-update dbh pgdb-data-id))) (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time))) (hash-table-set! smallest-last-update-time "smallest-time" last-update))) (pgdb:update-test-data dbh pgdb-data-id pgdb-test-id category variable value expected tol units comment status type last-update)) (begin (debug:print-info 4 *default-log-port* "Inserting test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id) (if (handle-exceptions exn (begin (print-call-chain) (debug:print 0 *default-log-port* ((condition-property-accessor 'exn 'message) exn)) #f) (pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type last-update)) ;(tasks:run-id->mtpg-run-id dbh cached-info run-id area-info) (begin ;(pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type ) (if (or (not smallest-time) (< last-update smallest-time)) (hash-table-set! smallest-last-update-time "smallest-time" last-update)) (set! pgdb-data-id (pgdb:get-test-data-id dbh pgdb-test-id category variable))) #f))) (hash-table-set! data-ht data-id pgdb-data-id )) (begin (debug:print-info 1 *default-log-port* "Error: Test not in pgdb")))) (debug:print-info 1 *default-log-port* "Error: Could not get test data info for data id " test-data-id )))) ;; this is a wierd senario need to debug test-data-ids))) (define (tasks:sync-tests-data dbh cached-info test-ids area-info smallest-last-update-time main-run-id) (let ((test-ht (hash-table-ref cached-info 'tests)) (run-id-in main-run-id)) (for-each (lambda (test-id) ; (set! run-id-in (cdr test-id)) ; (set! test-id (car test-id)) (debug:print 0 *default-log-port* "test-id: " test-id " run-id: " run-id-in) (let* ((test-info (rmt:get-test-info-by-id run-id-in test-id)) (run-id (db:test-get-run_id test-info)) ;; look these up in db_records.scm (test-id (db:test-get-id test-info)) (test-name (db:test-get-testname test-info)) (item-path (db:test-get-item-path test-info)) (state (db:test-get-state test-info)) (status (db:test-get-status test-info)) (host (db:test-get-host test-info)) |
︙ | ︙ | |||
968 969 970 971 972 973 974 975 976 977 978 | (begin ;(print pgdb-run-id) (pgdb:get-test-id dbh pgdb-run-id test-name item-path)) #f))) ;; "id" "run_id" "testname" "state" "status" "event_time" ;; "host" "cpuload" "diskfree" "uname" "rundir" "item_path" ;; "run_duration" "final_logf" "comment" "shortdir" "attemptnum" "archived" (if pgdb-run-id (begin (if pgdb-test-id ;; have a record (begin ;; let ((key-name (conc run-id "/" test-name "/" item-path))) | > > | | | 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 | (begin ;(print pgdb-run-id) (pgdb:get-test-id dbh pgdb-run-id test-name item-path)) #f))) ;; "id" "run_id" "testname" "state" "status" "event_time" ;; "host" "cpuload" "diskfree" "uname" "rundir" "item_path" ;; "run_duration" "final_logf" "comment" "shortdir" "attemptnum" "archived" (if (or (not item-path) (string-null? item-path)) (debug:print-info 0 *default-log-port* "Working on Run id : " run-id " and test name : " test-name)) (if pgdb-run-id (begin (if pgdb-test-id ;; have a record (begin ;; let ((key-name (conc run-id "/" test-name "/" item-path))) (debug:print-info 4 *default-log-port* "Updating existing test with run-id: " run-id " and test-id: " test-id " pgdb run id: " pgdb-run-id " pgdb-test-id " pgdb-test-id) (let* ((pgdb-last-update (pgdb:get-test-last-update dbh pgdb-test-id))) (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time))) ;;if last-update is same as pgdb-last-update then it is safe to assume the records are identical and we can use a larger last update time. (hash-table-set! smallest-last-update-time "smallest-time" last-update))) (pgdb:update-test dbh pgdb-test-id pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived last-update pid)) (begin (debug:print-info 4 *default-log-port* "Inserting test with run-id: " run-id " and test-id: " test-id " pgdb run id: " pgdb-run-id) (pgdb:insert-test dbh pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived last-update pid) (if (or (not smallest-time) (< last-update smallest-time)) (hash-table-set! smallest-last-update-time "smallest-time" last-update)) (set! pgdb-test-id (pgdb:get-test-id dbh pgdb-run-id test-name item-path)))) (hash-table-set! test-ht test-id pgdb-test-id)) (debug:print-info 1 *default-log-port* "WARNING: Skipping run with run-id:" run-id ". This run was created after privious sync and removed before this sync.")))) test-ids))) |
︙ | ︙ | |||
1011 1012 1013 1014 1015 1016 1017 | #f) (if (not (pgdb:is-area-taged-with-a-tag dbh (vector-ref tag-info 0) (vector-ref area-info 0))) (pgdb:insert-area-tag dbh (vector-ref tag-info 0) (vector-ref area-info 0)))))) (define (tasks:sync-run-data dbh cached-info run-ids area-info smallest-last-update-time) (for-each (lambda (run-id) | | | < | | | | | | | | | | | | | > > > | | | | | < < < > | | | | | | > > > > > > | | < < < < < > | | 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 | #f) (if (not (pgdb:is-area-taged-with-a-tag dbh (vector-ref tag-info 0) (vector-ref area-info 0))) (pgdb:insert-area-tag dbh (vector-ref tag-info 0) (vector-ref area-info 0)))))) (define (tasks:sync-run-data dbh cached-info run-ids area-info smallest-last-update-time) (for-each (lambda (run-id) (debug:print-info 4 *default-log-port* "Check if run with " run-id " needs to be synced" ) (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time)) run-ids)) ;; get runs changed since last sync ;; (define (tasks:sync-test-data dbh cached-info area-info) ;; (let* (( (define (tasks:sync-to-postgres configdat dest) ;; (print "In sync") (let* ((dbh (pgdb:open configdat dbname: dest)) (area-info (pgdb:get-area-by-path dbh *toppath*)) (cached-info (make-hash-table)) (start (current-seconds)) (test-patt (if (args:get-arg "-testpatt") (args:get-arg "-testpatt") "%")) (target (if (args:get-arg "-target") (args:get-arg "-target") #f)) (run-name (if (args:get-arg "-runname") (args:get-arg "-runname") #f))) (if (and target (not run-name)) (begin (debug:print 0 *default-log-port* "Error: Provide runname") (exit 1))) (if (and (not target) run-name) (begin (debug:print 0 *default-log-port* "Error: Provide target") (exit 1))) ;(print "123") ;(exit 1) (for-each (lambda (dtype) (hash-table-set! cached-info dtype (make-hash-table))) '(runs targets tests steps data)) (hash-table-set! cached-info 'start start) ;; when done we'll set sync times to this (if area-info (let* ((last-sync-time (if (and target run-name) 0 (if (args:get-arg "-since") (string->number (args:get-arg "-since")) (vector-ref area-info 3)))) (smallest-last-update-time (make-hash-table)) (run-ids (if (and target run-name) (rmt:get-run-record-ids target run-name (rmt:get-keys)) (rmt:get-changed-record-run-ids last-sync-time))) (all-run-ids (if (and target run-name) '() (rmt:get-all-runids))) (changed-run-dbs (if (and target run-name) '() (db:get-changed-run-ids last-sync-time))) (changed-run-ids (if (and target run-name) run-ids (filter (lambda (run) (member (modulo run (num-run-dbs)) changed-run-dbs)) all-run-ids))) (area-tag (if (args:get-arg "-area-tag") (args:get-arg "-area-tag") (if (args:get-arg "-area") (args:get-arg "-area") "")))) (if (and (equal? area-tag "") (not (pgdb:is-area-taged dbh (vector-ref area-info 0)))) (set! area-tag *default-area-tag*)) (if (not (equal? area-tag "")) (task:add-area-tag dbh area-info area-tag)) (if (not (null? run-ids)) (begin (debug:print-info 0 *default-log-port* "syncing runs: " run-ids) (tasks:sync-run-data dbh cached-info run-ids area-info smallest-last-update-time))) (for-each (lambda (run-id) (let ((test-ids (rmt:get-changed-record-test-ids run-id last-sync-time))) (print test-ids) (if (not (null? test-ids)) (begin (debug:print-info 0 *default-log-port* "syncing tests: " test-ids) (tasks:sync-tests-data dbh cached-info test-ids area-info smallest-last-update-time run-id))))) changed-run-ids) (let* ((smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" (current-seconds)))) (debug:print-info 0 "smallest-time :" smallest-time " last-sync-time " last-sync-time) (if (not (and target run-name)) (if (or (and smallest-time (> smallest-time last-sync-time)) (and smallest-time (eq? last-sync-time 0))) (pgdb:write-sync-time dbh area-info smallest-time))))) ;;this needs to be changed (if (tasks:set-area dbh configdat) (tasks:sync-to-postgres configdat dest) (begin (debug:print 0 *default-log-port* "ERROR: unable to create an area record") #f))))) |
Modified tcmt.scm from [6658a745e5] to [2cd967b1fa].
︙ | ︙ | |||
19 20 21 22 23 24 25 26 27 28 29 30 | ;; ;; Wrapper to enable running Megatest flows under teamcity ;; ;; 1. Run the megatest process and pass it all the needed parameters ;; 2. Every five seconds check for state/status changes and print the info ;; (use srfi-1 posix srfi-69 srfi-18 regex defstruct) (use trace) ;; (trace-call-sites #t) | > > > > > > > | | | < | 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 | ;; ;; Wrapper to enable running Megatest flows under teamcity ;; ;; 1. Run the megatest process and pass it all the needed parameters ;; 2. Every five seconds check for state/status changes and print the info ;; (declare (uses mtargs)) (declare (uses rmt)) (declare (uses rmtmod)) (declare (uses common)) ;; (declare (uses megatest-version)) (declare (uses commonmod)) (use srfi-1 posix srfi-69 srfi-18 regex defstruct) (use trace) ;; (trace-call-sites #t) (import commonmod rmtmod (prefix mtargs args:)) (include "megatest-version.scm") (include "megatest-fossil-hash.scm") (include "db_records.scm") (define origargs (cdr (argv))) (define remargs (args:get-args |
︙ | ︙ |
Added tcp-transportmod.scm version [b9c6fed28d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;;====================================================================== ;; 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 tcp-transportmod)) (declare (uses debugprint)) (declare (uses commonmod)) (declare (uses dbfile)) (declare (uses dbmod)) (declare (uses portlogger)) (use address-info tcp) (module tcp-transportmod * (import scheme) (cond-expand (chicken-4 (import (prefix sqlite3 sqlite3:) chicken extras hostinfo ports posix files data-structures directory-utils tcp )) (chicken-5 (import chicken.base chicken.condition chicken.file chicken.pathname chicken.process-context.posix chicken.process chicken.sort chicken.string chicken.time chicken.tcp chicken.random chicken.file.posix chicken.pretty-print chicken.io chicken.port chicken.process-context system-information) (define unsetenv unset-environment-variable!) )) (import address-info directory-utils matchable md5 message-digest regex regex-case s11n srfi-1 srfi-18 srfi-4 srfi-69 stack typed-records tcp-server debugprint commonmod dbfile dbmod portlogger ) ;;====================================================================== ;; client ;;====================================================================== ;; (define keep-age-param (make-parameter 10)) ;; qif file age, if over move to attic ;; Used ONLY for client ;; (defstruct tt-conn host port host-port dbfname server-id server-start servinf-file pid ) ;; Used for BOTH clients and servers (defstruct tt ;; client related (conns (make-hash-table)) ;; dbfname -> conn ;; server related (state 'starting) (areapath #f) (host #f) (port #f) (conn #f) (cleanup-proc #f) (handler #f) ;; receives data and responds (socket #f) (thread #f) (host-port #f) (cmd-thread #f) (ro-mode #f) (ro-mode-checked #f) (last-access (current-seconds)) (servinf-file #f) (last-serv-start 0) ) ;; parameters ;; (define tt-server-timeout-param (make-parameter 600)) ;; make ttdat visible (define *server-info* #f) (define *server-run* #t) (define (tt:make-remote areapath) (make-tt areapath: areapath)) ;; 1 ... or #f ;; and check that dbfname matches. FIXME: the propagation of dbfname and run-id ;; might not make the best sense ;; (define (tt:valid-run-id run-id dbfname) (and (or (number? run-id) (not run-id)) (equal? (dbfile:run-id->dbfname run-id) dbfname))) (tcp-buffer-size 2048) ;; (max-connections 4096) (define (tt:get-conn ttdat dbfname) (hash-table-ref/default (tt-conns ttdat) dbfname #f)) ;; do all the busy work of finding and setting up conn for ;; connecting to a server ;; This function, `tt:client-connect-to-server`, is designed to manage connections between a client and a server within a testing framework. ;; The function takes four arguments: ;; 1. `ttdat`: a data structure that holds information about the testing environment or connections. ;; 2. `dbfname`: The name of the database file that the client wants to connect to. ;; 3. `run-id`: An identifier for the current run of the test suite. ;; 4. `testsuite`: The test suite that is being run. ;; ;; Here's a step-by-step explanation of what the function does: ;; ;; 1. It first asserts that the `run-id` is valid for the given `dbfname` using the `tt:valid-run-id` function. If the `run-id` is not valid, it raises a fatal error. ;; 2. It prints debug information indicating that the function `tt:client-connect-to-server` has been called with the given `dbfname`. ;; 3. It attempts to retrieve an existing connection to the server from a hash table (`tt-conns`) using the `dbfname` as the key. If a connection already exists, it prints debug information and returns the existing connection. ;; 4. If no existing connection is found, it retrieves the current server information from the servinfo file, using the `tt:get-current-server-info` function. ;; 5. It uses pattern matching to destructure the server information into variables (`host`, `port`, `start-time`, `server-id`, `pid`, `dbfname2`, `servinffile`). It then asserts that the `dbfname` from the server info matches the one provided to the function. ;; 6. It constructs a connection object (`conn`) with the server information. ;; 7. It attempts to ping the server using `tt:timed-ping` to verify that the server is running and can be communicated with. ;; 8. Depending on the result of the ping: ;; - If the server is running (`running`), it prints debug information, saves the connection in the hash table, and returns the connection. ;; - If the server is starting (`starting`), it sleeps for 2 seconds and then recursively calls itself to retry the connection. ;; - If the server is neither running nor starting, it checks if it's been more than 10 seconds since the last server start attempt. If so, it attempts to start the server using `server-start-proc` and then sleeps for 1 second before retrying the connection. ;; 9. If no server information is found (`else` case), it checks if it's been more than 3 seconds since the last server start attempt. If so, it starts a new server using `server-start-proc`, updates the last server start time, and sleeps for 4 seconds. ;; 10. It then sleeps for 1 second and prints debug information before recursively calling itself to retry the connection. ;; ;; The function uses recursion to keep trying to connect to the server, with various sleep intervals to prevent overwhelming the system with connection attempts or server starts. ;; It also uses a hash table to cache connections and avoid reconnecting to a server if a connection already exists. ;; The function is designed to handle different server states and ensure that a server is running and available before returning a valid connection to the caller. ;; (define (tt:client-connect-to-server ttdat dbfname run-id testsuite server-start-proc) (assert (tt:valid-run-id run-id dbfname) "FATAL: invalid run-id "run-id) (debug:print-info 2 *default-log-port* "tt:client-connect-to-server " dbfname) (let* ((conn (tt:get-conn ttdat dbfname)) (server-start-proc (or server-start-proc (lambda () (assert (equal? dbfname "main.db") ;; only main.db is started here "FATAL: called server-start-proc for db other than main.db") (tt:server-process-run (tt-areapath ttdat) testsuite ;; (dbfile:testsuite-name) (common:find-local-megatest) run-id))))) (if conn (begin (debug:print-info 2 *default-log-port* "already connected to a server for " dbfname) conn) ;; we are already connected to the server ;; no conn ;; find server with lowest number of threads running (i.e. lowest load) ;; (let* ((sdats (tt:get-server-info-sorted ttdat dbfname)) (sdat (if (null? sdats) #f ;; choose server with lowest threads count (car (sort sdats (lambda (a b) (let* ((load-a (tt:get-server-threads a)) (load-b (tt:get-server-threads b))) (< load-a load-b)))))))) ;; (let ((indx (max (random (- (length sdats) 1)) 0))) ;; (list-ref sdats indx))))) ;; (debug:print-info 1 *default-log-port* "found sdat " sdat" from sdats: "sdats) (match sdat ((host port start-time server-id pid dbfname2 servinffile) (assert (equal? dbfname dbfname2) "FATAL: read server info from wrong file.") (debug:print-info 2 *default-log-port* "no conn - in match servinffile:" servinffile) (let* ((host-port (conc host":"port)) (conn (make-tt-conn host: host port: port host-port: host-port dbfname: dbfname servinf-file: servinffile server-id: server-id server-start: start-time pid: pid))) ;; verify we can talk to this server (let* ((result (tt:timed-ping host port server-id)) (ping-res (car result)) (ping (cdr result))) (debug:print-info 2 *default-log-port* "host " host " port " port " ping time: " ping " result " ping-res) (case ping-res ((running) (debug:print-info 2 *default-log-port* "Setting conn = " conn " in hash table") (hash-table-set! (tt-conns ttdat) dbfname conn) ;;; is this ok to save before validating that the connection is good? conn) ((starting) (thread-sleep! 0.5) (debug:print-info 0 *default-log-port* "server for " dbfname " is in starting state, retrying connect") (tt:client-connect-to-server ttdat dbfname run-id testsuite server-start-proc)) (else (let* ((curr-secs (current-seconds))) ;; rm the (last server) would go here (if (> (- curr-secs (tt-last-serv-start ttdat)) 10) (begin (debug:print-info 0 *default-log-port* "Unreachable server at " host":"port" with servinfo file "servinffile", removing it") (if (file-exists? servinffile) (handle-exceptions exn #f (delete-file servinffile))) (tt-last-serv-start-set! ttdat curr-secs) (debug:print-info 0 *default-log-port* "Starting a new server on " (get-host-name)) (server-start-proc))) ;; start server if 10 sec since last attempt (thread-sleep! 1) (debug:print-info 0 *default-log-port* "Retrying connect") (tt:client-connect-to-server ttdat dbfname run-id testsuite server-start-proc))))))) (else ;; no good server found, if haven't started server in > 5 secs, start another (if (> (- (current-seconds) (tt-last-serv-start ttdat)) 3) ;; BUG - grow this number really do not want to swamp the machine with servers (begin (debug:print-info 0 *default-log-port* "Starting server for "dbfname " on " (get-host-name)) (server-start-proc) (tt-last-serv-start-set! ttdat (current-seconds)) (thread-sleep! 6) )) (thread-sleep! 1) (debug:print-info 0 *default-log-port* "Connect to server from " (get-host-name) " for " dbfname) (tt:client-connect-to-server ttdat dbfname run-id testsuite server-start-proc))))))) ;; returns ( result . ping_time ) (define (tt:timed-ping host port server-id) (let* ((start-time (current-milliseconds)) (result (tt:ping host port server-id))) (cons result (- (current-milliseconds) start-time)))) ;; host:port => ( meta . when-updated) (define *server-load* (make-hash-table)) (define (tt:save-server-meta host port meta) (hash-table-set! *server-load* (conc host":"port) (cons meta (current-seconds)))) (define (tt:get-server-threads dat) (let* ((host (car dat)) (port (cadr dat)) (dat (tt:get-server-meta host port #t))) ;; (debug:print 0 *default-log-port* "host: "host" port: "port" dat: "dat) (if (list? dat) (or (alist-ref 'sload dat) 99998) 99999))) ;; absurd number means don't use this one ;; lazy get, does not auto-refresh meta, this might be a problem ;; (define (tt:get-server-meta host port #!optional (do-ping #f)) (let* ((get-meta (lambda () (let* ((dat (hash-table-ref/default *server-load* (conc host":"port) #f))) (if dat (car dat) #f)))) (meta (get-meta))) (if (and (not meta) do-ping) (begin (tt:timed-ping host port #f) (get-meta)) meta))) (define (tt:wait-on-server-load run-id ttdat) (if ttdat ;; if no server yet just pass on through (let* ((dbfname (dbmod:run-id->dbfname run-id)) (get-lowest-thread-load (lambda () (let* ((sdats (tt:get-server-info-sorted ttdat dbfname))) (car (map tt:get-server-threads sdats)))))) (if ttdat (let loop ((count 0)) (let* ((lowestload (get-lowest-thread-load))) (if (> lowestload 5) ;; load is pretty high (begin (debug:print 0 *default-log-port* "Servers appear overloaded with "lowestload" threads, waiting...") (thread-sleep! 1) (if (< count 10) (loop (+ count 1))))))) (debug:print 0 *default-log-port* "Can't wait on server load, *ttdat* not set"))))) (define (tt:ping host port server-id #!optional (tries-left 5)) (let* ((res (tt:send-receive-direct host port `(ping #f #f #f) ping-mode: #t)) ;; please send me your server-id (try-again (lambda () (if (> tries-left 0) (begin (thread-sleep! 1) (tt:ping host port server-id (- tries-left 1))) #f)))) ;; ;; need two threads, one a 5 second timer ;; (match res ((status errmsg result meta) (tt:save-server-meta host port meta) (if (equal? result server-id) (let* ((server-state (alist-ref 'sstate meta))) ;; (debug:print 0 *default-log-port* "Ping to "host":"port" successful.") (or server-state 'unk)) ;; then we are good (begin (if server-id (debug:print 0 *default-log-port* "WARNING: server-id does not match, expected: "server-id", got: "result)) #f))) (else ;; (debug:print 0 *default-log-port* "res not in form (status errmsg result meta), got: "res) (try-again))))) ;; client side handler ;; ;;(tt:handler #<tt> get-keys #f () 2 #f "/home/matt/data/megatest/ext-tests" #f "main.db" "ext-tests" "/home/matt/data/megatest/bin/.22.04/../megatest") ;;g (define (tt:handler ttdat cmd run-id params attemptnum readonly-mode dbfname testsuite mtexe server-start-proc) ;; connect-to-server will start a server if needed. (let* ((areapath (tt-areapath ttdat)) (conn (tt:client-connect-to-server ttdat dbfname run-id testsuite server-start-proc))) ;; looks up conn keyed by dbfname (if conn ;; have connection, call the server (let* ((res (tt:send-receive ttdat conn cmd run-id params))) ;; res is (status errmsg result meta) (match res ((status errmsg result meta) (if (list? meta) (let* ((delay-wait (alist-ref 'delay-wait meta))) (if (and (number? delay-wait) (> delay-wait 0)) (begin (debug:print 0 *default-log-port* "Server is loaded, delaying "delay-wait" seconds") (thread-sleep! delay-wait))))) (case status ((busy) ;; result will be how long the server wants you to delay (let* ((raw-dly (if (number? result) result 0.1)) (dly (+ raw-dly (/ attemptnum 10)))) ;; (* raw-dly (/ attemptnum 2)))) (debug:print 0 *default-log-port* "WARNING: server for "dbfname" is busy, cmd is "cmd", will try again in "dly" seconds. This is attempt "(- attemptnum 1)) (debug:print 0 *default-log-port* errmsg) (thread-sleep! dly) (tt:handler ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe server-start-proc))) ((loaded) (debug:print 0 *default-log-port* "WARNING: server for "dbfname" is loaded, slowing queries.") (tt:backoff-incr (tt-conn-host conn)(tt-conn-port conn)) ;; this would be a good place to force reconnection and connect to a different server result) ;; (tt:handler ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe)) (else result))) (else ;; did not receive properly formated result (if (not res) ;; tt:send-receive telling us that communication failed (let* ((host (tt-conn-host conn)) (port (tt-conn-port conn)) ;; (dbfname (tt-conn-port conn)) ;; 192.168.0.127:4242-726924:4.db (pid (tt-conn-pid conn)) ;;(servinf (tt-conn-servinf-file conn))) (servinf (tt-servinf-file ttdat))) ;; (conc areapath"/.servinfo/"host":"port"-"pid":"dbfname))) ;; TODO, use (server:get-servinfo-dir areapath) (hash-table-set! (tt-conns ttdat) dbfname #f) ;; clear out the conn for this dbfname to force finding new server (if (and servinf (file-exists? servinf)) (begin (if (< attemptnum 10) (begin (thread-sleep! 0.5) (tt:handler ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe server-start-proc)) (begin (debug:print 0 *default-log-port* "INFO: no response from server "host":"port" for "dbfname) (if (and (file-exists? servinf) (> (- (current-seconds)(file-modification-time servinf)) 60)) (begin (debug:print 0 *default-log-port* "INFO: "servinf" file seems old and no ping response, removing it.") (handle-exceptions exn #f (delete-file* servinf)) (tt:handler ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe server-start-proc)) (begin ;; start server - addressed in client-connect-to-server ;; delay - addressed in client-connect-to-server ;; try again (thread-sleep! 0.25) ;; dunno, I think this needs to be here (tt:handler ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe server-start-proc)) )))) (begin ;; no server file, delay and try again (debug:print 2 *default-log-port* "INFO: connection to server "host":"port" broken for "dbfname", no servinf file. Server exited? ") (thread-sleep! 0.5) (tt:handler ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe server-start-proc)))) (begin ;; this case is where res is malformed. Probably should abort (assert #f "FATAL: tt:handler received bad data "res) ;; (debug:print 0 *default-log-port* "INFO: got corrupt data from server "host":"port", "res", for "dbfname", will try again.") ;; (tt:handler ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe) ))))) (begin (thread-sleep! 1) ;; no conn yet set up, give it a rest and try again (tt:handler ttdat cmd run-id params attemptnum readonly-mode dbfname testsuite mtexe server-start-proc))))) ;; gets server info and appends path to server file ;; sorts by age, --oldest-- now newest first ;; ;; move the ping here? ;; ;; returns list of (host port startseconds server-id servinfofile) ;; (define (tt:get-server-info-sorted ttdat dbfname) (let* ((areapath (tt-areapath ttdat)) (sfiles (tt:find-server areapath dbfname)) (sdats (filter car (map tt:server-get-info sfiles))) ;; first element is #f if the file disappeared while being read (sorted (sort sdats (lambda (a b) (let* ((starta (list-ref a 2)) (startb (list-ref b 2))) (if (eq? starta startb) (string>? (list-ref a 3)(list-ref b 3)) ;; if servers started at same time look at server-id (> starta startb)))))) (count 0)) (for-each (lambda (rec) (if (or (> (length sorted) 1) (common:low-noise-print 120 "server info sorted")) (debug:print 2 *default-log-port* "SERVER #"count": "(string-intersperse (map conc sorted) ", "))) (set! count (+ count 1))) sorted) sorted)) (define (tt:send-receive ttdat conn cmd run-id params) (let* ((host-port (tt-conn-host-port conn)) ;; (conc (tt-conn-host conn)":"(tt-conn-port conn))) (host (tt-conn-host conn)) (port (tt-conn-port conn)) (dat (list cmd run-id params #f))) ;; no meta data yet (tt:send-receive-direct host port dat))) (defstruct tt:backoff (last-ioerr (current-seconds)) (last-adj-t (current-seconds)) (wait-delay 0.1)) (define *tt:backoff-smoothing* (make-hash-table)) ;; host:port => lastaccess backoffdelay ) (define (tt:backoff-incr host port) ;; call if tcp fails i/o net (let* ((host-port (conc host":"port)) (bkoff (hash-table-ref/default *tt:backoff-smoothing* host-port #f))) (if bkoff (begin (tt:backoff-last-ioerr-set! bkoff (current-seconds)) (tt:backoff-wait-delay-set! bkoff (+ (tt:backoff-wait-delay bkoff) 0.1))) (hash-table-set! *tt:backoff-smoothing* host-port (make-tt:backoff))))) (define (tt:backoff-decr-and-wait host port) (let* ((host-port (conc host":"port)) (bkoff (hash-table-ref/default *tt:backoff-smoothing* host-port #f))) (if bkoff (let* ((wait-delay (tt:backoff-wait-delay bkoff)) (last-ioerr (tt:backoff-last-ioerr bkoff)) (last-adj-t (tt:backoff-last-adj-t bkoff)) (delta (- (current-seconds) last-adj-t)) (adj (* delta 0.001)) ;; it takes 100 seconds to recover from hitting an io err (new-wait (if (> wait-delay 0) (if (> adj wait-delay) 0 (- wait-delay adj)) 0))) (if (> new-wait 0) (begin (if (common:low-noise-print 10 "delay wait message") (debug:print-info 0 *default-log-port* "Server on host " host " loaded, DelayWait: "new-wait)) (tt:backoff-wait-delay-set! bkoff new-wait) (tt:backoff-last-adj-t-set! bkoff (current-seconds)) (thread-sleep! new-wait)) (hash-table-delete! *tt:backoff-smoothing* host-port)))))) (define (tt:send-receive-direct host port dat #!key (ping-mode #f)(tries-remaining 25)) (assert (number? port) "FATAL: tt:send-receive-direct called with a port that is not a number "port) (tt:backoff-decr-and-wait host port) (let* ((retry (lambda () (tt:send-receive-direct host port dat tries-remaining: (- tries-remaining 1)))) (full-err-print (lambda (exn msg) (if (condition? exn) (begin (pp (condition->list exn) *default-log-port*) (pp dat *default-log-port*) (debug:print 0 *default-log-port* msg ", error: " ((condition-property-accessor 'exn 'message) exn) ", arguments: " ((condition-property-accessor 'exn 'arguments) exn) ", location: " ((condition-property-accessor 'exn 'location) exn) )) (debug:print 0 *default-log-port* msg "(note: exn="exn", is not a condition object."))))) (condition-case (let-values (((inp oup)(tcp-connect host port))) (let ((res (if (and inp oup) (begin (serialize dat oup) (close-output-port oup) (deserialize inp)) ))) (close-input-port inp) (match res ((result exn-result stdout-result) (if exn-result (full-err-print exn-result "ERROR: Server side exception detected")) (if stdout-result (debug:print 0 *default-log-port* "ERROR: Output detected on stdout on server side execution => "stdout-result)) result) (else (debug:print 0 *default-log-port* "ERROR: server returned non-standard output: "res) #f)))) (exn (io-error) (full-err-print exn "ERROR: i/o error") (tt:backoff-incr host port) #f) (exn (i/o net) (if ping-mode #f (cond ((> tries-remaining 4) ;; server likely defunct (tt:backoff-incr host port) #f) ((>= tries-remaining 0) (let* ((backoff-delay (max (* (- 26 tries-remaining) 0.1) 1.0))) (debug:print 0 *default-log-port* "WARNING: TCP overload, trying again in "backoff-delay"s.") (thread-sleep! backoff-delay) (tt:backoff-incr host port) (retry)) ;; (assert #f "FATAL: Too many retries in tt:send-receive-direct") ) (else #f)))) (exn () (full-err-print exn "Unhandled exception from client side.") #f)))) ;;====================================================================== ;; server ;;====================================================================== (define (tt:sync-dbs ttdat) #f) (define *server-start-requests* '()) ;; start the listener and start responding to requests ;; ;; NOTE: organise by dbfname, not run-id so we don't need ;; to pull in more modules ;; ;; This is the routine called in megatest.scm to start a server. NOTE: sequence is different for main.db vs. X.db ;; ;; Server viability is checked in keep-running. Blindly start and run here. ;; (define (tt:start-server areapath run-id dbfname-in handler keys) (assert areapath "FATAL: areapath not provided for tt:start-server") (let* ((ttdat (make-tt areapath: areapath)) (dbfname (or dbfname-in (dbmod:run-id->dbfname run-id)))) (set! *server-info* ttdat) (let* ((dbstruct (dbmod:open-dbmoddb areapath run-id dbfname (dbfile:db-init-proc) keys))) (tt-handler-set! ttdat (handler dbstruct)) (let* ((servinf-created #f) (tcp-thread (make-thread (lambda () ;; NOTE: tt-port and tt-host are set in connect-listener which is called under tt:start-tcp-server (tt:start-tcp-server ttdat)) ;; start the tcp-server which applies handler to incoming data "tcp-server-thread")) (run-thread (make-thread (lambda () (tt:keep-running ttdat dbfname dbstruct))))) (thread-start! tcp-thread) (let* ((areapath (tt-areapath ttdat)) (nosyncdbpath (conc areapath"/.mtdb")) (servers ;; (tt:find-server areapath dbfname))) (tt:get-server-info-sorted ttdat dbfname)) ;; (host port startseconds server-id servinfofile) (good-srvrs ;; contact servers via ping, if no response remove the .servinfo file (let loop ((servrs servers) (prime-host #f) (result '())) (if (null? servrs) (reverse result) (let* ((servdat (car servrs))) (match servdat ((host port startseconds server-id pid dbfilename servinfofile) (debug:print-info 0 *default-log-port* "Good servinfo file: " servdat) (let* ((ping-res (tt:timed-ping host port server-id)) (good-ping (match ping-res ((result . ping-time) (not result)) ;; we couldn't reach the server or it was not a megatest server (else #f))) ;; the ping failed completely? (same-host (or (not prime-host) ;; i.e. this is the first host (equal? prime-host host))) (keep-srv (and good-ping same-host))) (if keep-srv (loop (cdr servrs) host (cons servdat result)) (let* ((modtime (file-modification-time servinfofile))) ;; if the .servinfo hasn't been touched in five min ;; we can be pretty sure the server is truly dead (if (> (- (current-seconds) modtime) 360) (handle-exceptions exn (debug:print-info 0 *default-log-port* "Error removing server info file: "servinfofile", " (condition->list exn)) (delete-file* servinfofile)) (loop (cdr servrs) prime-host result)))))) (else ;; can't delete it as we don't have a filename. NOTE: Should never get here. (debug:print-info 0 *default-log-port* "ERROR: bad servinfo record \""servdat"\"") (loop (cdr servrs) prime-host result)) ;; drop ))))) (home-host (if (null? good-srvrs) #f (caar good-srvrs)))) ;; by here we have a trustworthy list of servers and we have removed the .servinfo file for any unresponsive servers ;; and the list is in good-srvrs ;; (cond ((not home-host) ;; no servers yet, go ahead and start (debug:print-info 0 *default-log-port* "No servers yet, starting on "(get-host-name))) ((> (length good-srvrs) 3) ;; don't need more, just exit (debug:print-info 0 *default-log-port* "Have "(length good-srvrs)", no need for more, exiting.") (exit)) ((not (equal? home-host (get-host-name))) ;; there is a home-host and we are not on it (debug:print-info 0 *default-log-port* "Prime main server is on host "home-host", but we are on host "(get-host-name)", exiting.") (exit)) (else (debug:print-info 0 *default-log-port* "Starting on host "(get-host-name)", along with "(length good-srvrs)" other servers."))) ;; this didn't seem to work, is port not available yet? (let loop ((count 0)) (if (tt-port ttdat) (begin (procinf-port-set! *procinf* (tt-port ttdat)) (procinf-dbname-set! *procinf* dbfname) (dbfile:with-no-sync-db nosyncdbpath (lambda (nsdb) (dbfile:insert-or-update-process nsdb *procinf*)))) (if (< count 10) (begin (thread-sleep! 0.25) (loop (+ count 1))) (begin (debug:print 0 *default-log-port* "ERROR: (tt-port ttdat) no port set! Exiting.") (exit))))) ;; create a servinfo file start keep-running ;; On WSL there seems to be a race condition where the .servinfo file ;; is not created fast enough (debug:print 0 *default-log-port* "Creating servinfo file for " dbfname) (tt:create-server-registration-file ttdat dbfname) (procinf-status-set! *procinf* "running") (tt-state-set! ttdat 'running) (dbfile:with-no-sync-db nosyncdbpath (lambda (nsdb) (dbfile:insert-or-update-process nsdb *procinf*))) (thread-start! run-thread) (thread-join! run-thread) ;; run thread will exit on timeout or other conditions ;; (tcp-close (tt-socket ttdat)) ;; close up ports here ;; replace with call to (dbfile:set-process-done nsdb host pid reason) (procinf-status-set! *procinf* "done") (procinf-end-set! *procinf* (current-seconds)) ;; either convert this to use set-process-done or get rid of set-process-done (dbfile:with-no-sync-db nosyncdbpath (lambda (nsdb) (dbfile:insert-or-update-process nsdb *procinf*))) (debug:print 0 *default-log-port* "Exiting now.") (exit)))))) (define (tt:keep-running ttdat dbfname dbstruct) (thread-sleep! 1) ;; at this point the server is running and responding to calls, we just monitor ;; for db calls and exit if there are none. ;; if I am not in the first 3 servers, exit (let* ((start-time (current-seconds))) (let loop () (let* ((servers (tt:get-server-info-sorted ttdat dbfname)) (home-host (if (null? servers) #f (caar servers))) (my-index (list-index (lambda (x) (equal? (list-ref x 6) (tt-servinf-file ttdat))) servers)) (ok (cond ((not my-index) (debug:print 0 *default-log-port* "WARNING: Apparently I don't exist.") #f) ;; keep trying or give up? ((not *server-run*) (debug:print 0 *default-log-port* "WARNING: received a stop server from client by remote request.") #f) ((null? servers) (debug:print 0 *default-log-port* "WARNING: no servinfo files found, this cannot be.") #f) ;; not ok ((> my-index 3) (debug:print 0 *default-log-port* "WARNING: there are more than three servers ahead of me, I'm not needed, exiting.") #f) ;; not ok to not be in first three ((eq? (tt-state ttdat) 'running) #t) ;; we are good to keep going ((> (- (current-seconds) start-time) 30) (debug:print 0 *default-log-port* "WARNING: over 30 seconds and not yet in runnning mode. Exiting.") #f) (else #t)))) (if ok (tt-last-access-set! ttdat *db-last-access*) ;; bit silly, just use db-last-access (begin (debug:print 0 *default-log-port* "Exiting immediately") (tt:shutdown-server ttdat) (exit))) (let* ((last-update (dbr:dbstruct-last-update dbstruct)) (curr-secs (current-seconds))) (if (and (eq? (tt-state ttdat) 'running) (> (- curr-secs last-update) 5)) ;; every 5 seconds update the db? (let* ((sinfo-file (tt-servinf-file ttdat))) ;; (debug:print 0 *default-log-port* "INFO: touching "sinfo-file) (set! (file-modification-time sinfo-file) (current-seconds)) ((dbr:dbstruct-sync-proc dbstruct) last-update) (dbr:dbstruct-last-update-set! dbstruct curr-secs)))) (if (< (- (current-seconds) (tt-last-access ttdat)) (tt-server-timeout-param)) ;; process any requests to start a new server due to load on this one (let* ((requests *server-start-requests*)) (set! *server-start-requests* '()) (if (> (length requests) 0) (debug:print-info 0 *default-log-port* "Processing "(length requests)" server start requests")) (for-each (lambda (proc) (proc) (thread-sleep! 1)) requests) (thread-sleep! 5) (loop))))) (tt:shutdown-server ttdat) (debug:print 0 *default-log-port* "INFO: Server timed out, exiting from tt:keep-running."))) (define (tt:shutdown-server ttdat) (let* ((host (tt-host ttdat)) (port (tt-port ttdat)) (sinf (tt-servinf-file ttdat))) (tt-state-set! ttdat 'shutdown) (portlogger:open-run-close portlogger:set-port port "released") (if (file-exists? sinf) (delete-file* sinf)) )) ;; return servid ;; side-effects: ;; ttdat-cleanup-proc is populated with function to remove the serverinfo file (define (tt:create-server-registration-file ttdat dbfname) (let* ((areapath (tt-areapath ttdat)) (servdir (tt:get-servinfo-dir areapath)) (host (tt-host ttdat)) (port (tt-port ttdat)) (servinf (conc servdir"/"host":"port"-"(current-process-id)":"dbfname)) (serv-id (tt:mk-signature areapath))) (assert (and host port) "FATAL: tt:create-server-registration-file called with no conn, dbfname="dbfname) (tt-servinf-file-set! ttdat servinf) (with-output-to-file servinf (lambda () (print "SERVER STARTED: "host":"port" AT "(current-seconds)" server-id: "serv-id" pid: "(current-process-id)" dbfname: "dbfname))) (let loop ((count 0)) (if (not (file-exists? servinf)) (begin (debug:print 0 *default-log-port* "WARNING: file "servinf" was created but it doesn't show up on disk! We'll try again.") (thread-sleep! 1) (if (> count 10) (debug:print 0 *default-log-port* "WARNING: file "servinf" was not created.") (loop (+ count 1)))))) serv-id)) ;; find valid server ;; get servers listed, last part of name must match :<dbfname> ;; if more than one, wait one second and look again ;; ;; NOTE: this only gets the servinfo data, no network activity here ;; i.e. no ping etc. ;; (define (tt:find-server areapath dbfname) (let* ((servdir (tt:get-servinfo-dir areapath)) (sfiles (glob (conc servdir"/*:"dbfname))) (goodfiles '())) ;; filter the files here by looking in processes table (if we are not main.db) ;; and or look at the time stamp on the servinfo file, a running server will ;; touch the file every minute (again, this will only apply for main.db) (for-each (lambda (fname) (let* ((age (- (current-seconds)(file-modification-time fname)))) (if (> age (tt-server-timeout-param)) ;; can't trust it if over server timeout old. (begin (debug:print 0 *default-log-port* "WARNING: removing stale servinfo file "fname", it is "age" seconds old") (handle-exceptions exn (debug:print 0 *default-log-port* "WARNING: error attempting to remove stale servinfo file "fname) (delete-file fname))) ;; (set! goodfiles (cons fname goodfiles))))) sfiles) goodfiles)) ;; given a path to a server info file return: host port startseconds server-id pid dbfname logf ;; example of what it's looking for in the file: ;; SERVER STARTED: 10.38.175.67:50216 AT 1616502350.0 server-id: 4907e90fc55c7a09694e3f658c639cf4 ;; (define (tt:server-get-info logf) (let ((server-rx (regexp "^SERVER STARTED: (\\S+):(\\d+) AT ([\\d\\.]+) server-id: (\\S+) pid: (\\d+) dbfname: (\\S+)")) ;; SERVER STARTED: host:port AT timesecs server id (bad-dat (list #f #f #f #f #f #f logf))) (let ((fdat (handle-exceptions exn (begin ;; BUG, TODO: add err checking, for now blanket ignore the errors? (debug:print-info 0 *default-log-port* "Unable to get server info from "logf ", exn="(condition->list exn)) '()) ;; no idea what went wrong, call it a bad server, return empty list (with-input-from-file logf read-lines)))) (if (null? fdat) ;; bad data, return bad-dat bad-dat (let loop ((inl (car fdat)) (tail (cdr fdat)) (lnum 0)) (let ((mlst (string-match server-rx inl))) (if (not mlst) (if (> lnum 500) ;; give up if more than 500 lines of server log read bad-dat (if (null? tail) bad-dat (loop (car tail)(cdr tail)(+ lnum 1)))) (match mlst ;; have a not null list ((_ host port start server-id pid dbfname) (list host (string->number port) (string->number start) server-id (string->number pid) dbfname logf)) (else (debug:print 0 *default-log-port* "ERROR: did not recognise SERVER line info "mlst) bad-dat))))))))) (define *last-server-start* (make-hash-table)) (define (tt:too-recent-server-start dbfname) (let* ((last-run-time (hash-table-ref/default *last-server-start* dbfname #f))) (and last-run-time (< (- (current-seconds) last-run-time) 5)))) (define *last-server-start-request-time* 0) ;; Given an area path, start a server process ### NOTE ### > file 2>&1 ;; if the target-host is set ;; try running on that host ;; incidental: rotate logs in logs/ dir. ;; (define (tt:server-process-run areapath testsuite mtexe run-id #!key (profile-mode "")) ;; areapath is *toppath* for a given testsuite area (assert areapath "FATAL: tt:server-process-run called without areapath defined.") (assert testsuite "FATAL: tt:server-process-run called without testsuite defined.") (assert mtexe "FATAL: tt:server-process-run called without mtexe defined.") ;; mtest -server - -m testsuite:ext-tests -db 6.db (let* ((dbfname (dbmod:run-id->dbfname run-id))) (if (or (< (- (current-seconds) *last-server-start-request-time*) 5) ;; attempted start less than 5 sec ago (tt:too-recent-server-start dbfname)) #f (let* ((load (get-normalized-cpu-load)) (srvrs (tt:find-server areapath dbfname)) (trying (length srvrs)) (nrun (number-of-processes-running (conc "mtest.*server.*"testsuite".*"dbfname)))) (set! *last-server-start-request-time* (current-seconds)) (cond ((> load 10.0) (debug:print 0 *default-log-port* "Normalized load " load " over 10, (load: " (commonmod:get-cpu-load) " cores: " (get-current-host-cores) " exiting...") (thread-sleep! 1) ;; I'm not convinced that a delay here is helpful. -mrw- #f) ((> nrun 100) (debug:print 0 *default-log-port* nrun" servers running on " (get-host-name) ", not starting another.") (thread-sleep! 1) #f) ((> trying 3) (debug:print 0 *default-log-port* trying" servers registered in .servinfo dir. not starting another.") (thread-sleep! 1) #f) (else (if (not (file-exists? (conc areapath"/logs"))) (create-directory (conc areapath"/logs") #t)) (let* ((logfile (conc areapath "/logs/server-"dbfname"-"(current-process-id)".log")) ;; -" curr-pid "-" target-host ".log")) (cmdln (conc mtexe " -startdir "areapath " -server - ";; (or target-host "-") " -m testsuite:"testsuite " -db "dbfname ;; (dbmod:run-id->dbfname run-id) " " profile-mode #;(conc " >> " logfile " 2>&1 &")))) ;; we want the remote server to start in *toppath* so push there ;; (push-directory areapath) ;; use cd in the command line instead (debug:print 2 *default-log-port* "INFO: Trying to start server in tcp mode (" cmdln ") at "(common:human-time)" for "areapath) ;; (debug:print 0 *default-log-port* "INFO: starting server at " (common:human-time)) (setenv "NBFAKE_QUIET" "yes") ;; BUG: change to with-environment-variable ... (setenv "NBFAKE_LOG" logfile) (system (conc "cd "areapath" ; nbfake " cmdln)) (unsetenv "NBFAKE_QUIET") (unsetenv "NBFAKE_LOG") ;; (system cmdln) (hash-table-set! *last-server-start* dbfname (current-seconds)) ;; ;; use below to go back to nbfake - nbfake does cause trouble ... ;; (setenv "NBFAKE_QUIET" "yes") ;; BUG: change to with-environment-variable ... ;; (setenv "NBFAKE_LOG" logfile) ;; (system (conc "cd "areapath" ; nbfake " cmdln)) ;; (unsetenv "NBFAKE_QUIET") ;; (unsetenv "NBFAKE_LOG") ;;(pop-directory) #t))))))) ;;====================================================================== ;; tcp connection stuff ;;====================================================================== ;; find a port and start tcp-server. This only starts the tcp portion of ;; the server, look at (tt:start-server ...) above for the entry point ;; for the entire server system ;; (define (tt:start-tcp-server ttdat) (setup-listener-portlogger ttdat) ;; set up tcp-listener (let* ((socket (tt-socket ttdat)) (handler (tt-handler ttdat)) ;; the handler comes from our client setting a handler function (handler-proc (lambda () (let* ((indat (deserialize)) ;; could use: (thread-terminate! (current-thread)) (result #f) (exn-result #f) (stdout-result (with-output-to-string (lambda () (let ((res (handle-exceptions exn (let* ((errdat (condition->list exn))) (set! exn-result errdat) (debug:print 0 *default-log-port* "ERROR: handler exception, these are bad, will exit in five seconds.") (pp errdat *default-log-port*) ;; these are always bad, set up an exit thread (thread-start! (make-thread (lambda () (thread-sleep! 5) (exit)))) #f) (handler indat) ;; this is the proc being called by the remote client ))) (set! result res))))) (full-result (list result exn-result (if (equal? stdout-result "") #f stdout-result)))) (handle-exceptions exn (begin (debug:print 0 *default-log-port* "Serialization failure. full-result="full-result) (thread-start! (make-thread (lambda () (thread-sleep! 5) (exit))))) ;; (serialize '(#f #f #f)) ;; doesn't work - the first call to serialize caused failure (serialize full-result)))))) ((make-tcp-server socket handler-proc) #f ;; yes, send error messages to std-err ))) ;; 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 (setup-listener uconn #!optional (port 4242)) ;; (assert (tt? uconn) "FATAL: setup-listener called with wrong struct "uconn) ;; (handle-exceptions ;; exn ;; (if (< port 65535) ;; (begin ;; (thread-sleep! 0.25) ;; (setup-listener uconn (+ port 1))) ;; #f) ;; (connect-listener uconn port))) (define (setup-listener-portlogger uconn) (let ((port (portlogger:open-run-close portlogger:find-port))) (assert (tt? uconn) "FATAL: setup-listener called with wrong struct "uconn) (debug:print 2 *default-log-port* "setup-listener-portlogger got port " port) (handle-exceptions exn (if (< port 65535) (begin (debug:print 0 *default-log-port* "setup-listener-portlogger: exception finding port. Retrying") (portlogger:open-run-close portlogger:set-failed port) (thread-sleep! 0.25) (setup-listener-portlogger uconn)) (begin (assert #t "setup-listener-portlogger: could not get a port") #f ) ) (debug:print 2 *default-log-port* "setup-listener-portlogger: got port " port) (connect-listener uconn port)))) (define (connect-listener uconn port) ;; (tcp-listener-socket LISTENER)(socket-name so) ;; sockaddr-address, sockaddr-port, sockaddr->string (let* ((tlsn (tcp-listen port 10000 #f)) ;; (tcp-listen TCPPORT [BACKLOG [HOST]]) (addr (tt:get-best-guess-address (get-host-name)))) ;; (get-my-best-address))) ;; (hostinfo-addresses (host-information (current-hostname))) (tt-port-set! uconn port) (tt-host-set! uconn addr) (tt-host-port-set! uconn (conc addr":"port)) (tt-socket-set! uconn tlsn) uconn)) ;;====================================================================== ;; utils ;;====================================================================== ;; Generate a unique signature for this server (define (tt:mk-signature areapath) (message-digest-string (md5-primitive) (with-output-to-string (lambda () (write (list areapath (current-process-id) (argv))))))) (define (tt:get-best-guess-address hostname) (let ((res #f)) (for-each (lambda (adr) (if (not (eq? (u8vector-ref adr 0) 127)) (set! res adr))) ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME (vector->list (hostinfo-addresses (hostname->hostinfo hostname)))) (string-intersperse (map number->string (u8vector->list (if res res (hostname->ip hostname)))) "."))) (define (tt:get-servinfo-dir areapath) (let* ((spath (conc areapath"/.servinfo"))) (if (not (file-exists? spath)) (create-directory spath #t)) spath)) ;;====================================================================== ;; network utilities ;;====================================================================== ;; NOTE: Look at address-info egg as alternative to some of this (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))) (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?)))))) (define (get-all-ips-sorted) (sort (get-all-ips) ip-pref-less?)) (define (get-all-ips) (map address-info-host (filter (lambda (x) (equal? (address-info-type x) "tcp")) (address-infos (get-host-name))))) ;;====================================================================== ;; Other Utils ;;====================================================================== (defstruct jstats (count 0) (jcount (make-hash-table)) ;; 1.db => journal_count ) ;; timeblk => jstats (define *journal-stats* #f) ;; (make-hash-table)) (define *journal-stats-enable* #t) ;; change to #f to turn off ;; monte-carlo-esque random sampling of journal files ;; for all the files: ;; if .journal ;; update stats +1 +1 ;; update stats +1 0 ;; (define (tt:write-load-tracking dbdir) (if *journal-stats-enable* (let* ((cs (current-seconds)) (key (inexact->exact (quotient cs 10))) (old (- key 5)) ;; 4 x 10 seconds ago (jstat (if (hash-table-exists? *journal-stats* key) (hash-table-ref *journal-stats* key ) (let ((new (make-jstats))) (hash-table-set! *journal-stats* key new) new)))) ;; clear out old records (for-each (lambda (key) (if (< key old) (hash-table-delete! *journal-stats* key))) (hash-table-keys *journal-stats*)) ;; increment our count of observations (jstats-count-set! jstat (+ (jstats-count jstat) 1)) ;; now find and increment journal file counts (directory-fold (lambda (fname res) ;; is it a journal file? (let ((parts (string-match "^(.*\\.db)-journal.*" fname))) (match parts ((_ dbfname) (hash-table-set! (jstats-jcount jstat) dbfname (+ (hash-table-ref/default (jstats-jcount jstat) dbfname 0) 1.0) )) (else #f) ))) '() dbdir )))) (define *journal-stats-mutex* (make-mutex)) (define (tt:journal-stats-run dbdir) (if (not *journal-stats*)(set! *journal-stats* (make-hash-table))) (let loop () (mutex-lock! *journal-stats-mutex*) (tt:write-load-tracking dbdir) (mutex-unlock! *journal-stats-mutex*) (thread-sleep! (/ (random 1000) 100.0)) (loop))) ;; call this to start a thread that is keeping the journal-stats up to date. (define (tt:start-stats dbdir) (thread-start! (make-thread (lambda ()(tt:journal-stats-run dbdir)) "Journal stats collection thread"))) (define (tt:get-journal-stats #!optional (dbfname #f)) (let* ((result (make-jstats)) (hitcounts (jstats-jcount result))) (if (and *journal-stats* *journal-stats-enable*) (begin (mutex-lock! *journal-stats-mutex*) (hash-table-for-each *journal-stats* (lambda (k v) ;; key jstats (let* ((count (jstats-count v)) (jcount (jstats-jcount v))) ;; dbfname => hit count (jstats-count-set! result (+ (jstats-count result) (jstats-count v))) (hash-table-for-each jcount (lambda (dbfname hit-count) (hash-table-set! hitcounts dbfname (+ hit-count (hash-table-ref/default hitcounts dbfname 0)))))))) (mutex-unlock! *journal-stats-mutex*)) (debug:print 0 *default-log-port* "INFO: *journal-stats* not set.")) ;; convert to normalized alist (let* ((tot (max (jstats-count result) 1)) ;; avoid divide by zero (hits (jstats-jcount result)) ;; 1.db => count (res (hash-table-map hits (lambda (fname hitcount) (cons fname (/ hitcount tot)))))) (if dbfname (or (alist-ref dbfname res equal?) 0) res)))) ;; megatest> (import tcp-transportmod) ;; megatest> (tt:write-load-tracking ".mtdb") ;; megatest> (hash-table-keys *journal-stats*) ;; (172060297) ;; megatest> (jstats->alist (hash-table-ref *journal-stats* 172060297)) ;; ((count . 1) (jcount . #<hash-table (1)>)) ;; megatest> (jstats-jcount (hash-table-ref *journal-stats* 172060297)) ;; #<hash-table (1)> ;; megatest> (hash-table->alist (jstats-jcount (hash-table-ref *journal-stats* 172060297))) ;; (("1.db" . 4)) ) |
Modified tdb.scm from [6edff6262d] to [9e1aed8275].
︙ | ︙ | |||
18 19 20 21 22 23 24 25 26 27 28 29 | ;; ;;====================================================================== ;;====================================================================== ;; Database access ;;====================================================================== (require-extension (srfi 18) extras tcp) (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) | > > > > > > > > > > > < | | < < | | | 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 | ;; ;;====================================================================== ;;====================================================================== ;; Database access ;;====================================================================== (declare (unit tdb)) (declare (uses debugprint)) (declare (uses common)) (declare (uses keys)) (declare (uses ods)) (declare (uses mt)) (declare (uses db)) (declare (uses commonmod)) (declare (uses mtargs)) (declare (uses rmtmod)) (require-extension (srfi 18) extras tcp) (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) (import commonmod debugprint rmtmod (prefix mtargs args:)) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") (include "run_records.scm") ;;====================================================================== |
︙ | ︙ |
Added testlocking/justtest.scm version [59ddbd6a63].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | (print "Starting at "(current-seconds)) (dbfile:with-simple-file-lock "justtesting.lock" (lambda () (print "got the lock at "(current-seconds)"!"))) (print "Done at: " (current-seconds)) (exit) |
Added testlocking/testlock.sh version [d778a78ed8].
> > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 | #!/bin/bash HRS=$(date +%H) MINS=$(($(date +%M) + 1)) if [[ $MINS -lt 10 ]];then MINS="0${MINS}" fi THETIME="$HRS:$MINS" echo "THETIME=$THETIME" for x in a b c d e f g h i j;do echo "megatest -load justtest.scm > $x.log" | at $THETIME done |
Modified tests.scm from [8b856ef5fd] to [f8f8a65eee].
︙ | ︙ | |||
19 20 21 22 23 24 25 | ;;====================================================================== ;;====================================================================== ;; Tests ;;====================================================================== (declare (unit tests)) | | | | | | | | | > | > | | | 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 | ;;====================================================================== ;;====================================================================== ;; Tests ;;====================================================================== (declare (unit tests)) (declare (uses db)) (declare (uses tdb)) (declare (uses debugprint)) (declare (uses common)) (declare (uses commonmod)) (declare (uses items)) (declare (uses runconfig)) (declare (uses server)) (declare (uses mtargs)) (declare (uses rmtmod)) (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking directory-utils) (import (prefix sqlite3 sqlite3:)) (import commonmod (prefix mtargs args:) debugprint rmtmod) (require-library stml) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") (include "js-path.scm") (define (init-java-script-lib) (set! *java-script-lib* (conc (common:get-install-area) "/share/js/jquery-3.1.0.slim.min.js")) ) ;; Call this one to do all the work and get a standardized list of tests ;; gets paths from configs and finds valid tests ;; returns hash of testname --> fullpath ;; (define (tests:get-all) (let* ((test-search-path (tests:get-tests-search-path *configdat*))) (debug:print 8 *default-log-port* "test-search-path: " test-search-path) (tests:get-valid-tests (make-hash-table) test-search-path))) (define (tests:get-tests-search-path cfgdat) (let ((paths (let ((section (if cfgdat (configf:get-section cfgdat "tests-paths") #f))) (if section (map cadr section) '())))) (filter (lambda (d) (if (directory-exists? d) d (begin ;; (if (common:low-noise-print 60 "tests:get-tests-search-path" d) ;; (debug:print 0 *default-log-port* "WARNING: problem with directory " d ", dropping it from tests path")) #f))) (append paths (list (conc *toppath* "/tests")))))) (define (tests:get-valid-tests test-registry tests-paths) (if (null? tests-paths) test-registry (let loop ((hed (car tests-paths)) |
︙ | ︙ | |||
133 134 135 136 137 138 139 140 141 142 143 144 145 146 | ;; (debug:print 0 *default-log-port* "res=" res) (cond ((string? res) res) ;;; FIX THE ROOT CAUSE HERE .... ((null? res) #f) ((string? (cdr res)) (cdr res)) ;; it is a pair ((string? (cadr res))(cadr res)) ;; it is a list (else cadr res)))))) ;; return items given config ;; (define (tests:get-items tconfig) (let ((items (hash-table-ref/default tconfig "items" #f)) ;; items 4 (itemstable (hash-table-ref/default tconfig "itemstable" #f))) ;; if either items or items table is a proc return it so test running | > > > > > > | 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 | ;; (debug:print 0 *default-log-port* "res=" res) (cond ((string? res) res) ;;; FIX THE ROOT CAUSE HERE .... ((null? res) #f) ((string? (cdr res)) (cdr res)) ;; it is a pair ((string? (cadr res))(cadr res)) ;; it is a list (else cadr res)))))) (define (tests:get-global-waitons rconfig) (let* ((global-waitons (runconfigs-get rconfig "!GLOBAL_WAITONS"))) (if (string? global-waitons) (string-split global-waitons) '()))) ;; return items given config ;; (define (tests:get-items tconfig) (let ((items (hash-table-ref/default tconfig "items" #f)) ;; items 4 (itemstable (hash-table-ref/default tconfig "itemstable" #f))) ;; if either items or items table is a proc return it so test running |
︙ | ︙ | |||
165 166 167 168 169 170 171 | " items: " items " itemstable: " itemstable) (items:get-items-from-config tconfig)) (else #f)))) ;; not iterated ;; returns waitons waitors tconfigdat ;; | | | | > > > > > > > > | 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 | " items: " items " itemstable: " itemstable) (items:get-items-from-config tconfig)) (else #f)))) ;; not iterated ;; returns waitons waitors tconfigdat ;; (define (tests:get-waitons test-name all-tests-registry global-waitons) (let* ((config (tests:get-testconfig test-name #f all-tests-registry 'return-procs))) ;; assuming no problems with immediate evaluation, this could be simplified ('return-procs -> #t) (let ((instr (if config (configf:lookup config "requirements" "waiton") (begin ;; No config means this is a non-existant test (debug:print-error 0 *default-log-port* "non-existent required test \"" test-name "\"") (exit 1)))) (instr2 (if config (configf:lookup config "requirements" "waitor") ""))) (debug:print-info 8 *default-log-port* "waitons string is " instr ", waitors string is " instr2) (let* ((newwaitons-tmp (string-split (cond ((procedure? instr) ;; here (let ((res (instr))) (debug:print-info 8 *default-log-port* "waiton procedure results in string " res " for test " test-name) res)) ((string? instr) instr) (else ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print-error 0 *default-log-port* "something went wrong in processing waitons for test " test-name) "")))) (newwaitors (string-split (cond ((procedure? instr2) (let ((res (instr2))) (debug:print-info 8 *default-log-port* "waitor procedure results in string " res " for test " test-name) res)) ((string? instr2) instr2) (else ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print-error 0 *default-log-port* "something went wrong in processing waitons for test " test-name) "")))) (newwaitons (if (and (list? global-waitons) (not (null? global-waitons))) (begin (debug:print 0 *default-log-port* "Adding global waitons " global-waitons) (append newwaitons-tmp (filter (lambda (x) ;; remove self from global waitons (not (equal? x test-name))) global-waitons))) newwaitons-tmp))) (values ;; the waitons (filter (lambda (x) (if (hash-table-ref/default all-tests-registry x #f) #t (begin (debug:print-error 0 *default-log-port* "test " test-name " has unrecognised waiton testname " x) |
︙ | ︙ | |||
537 538 539 540 541 542 543 | (equal? logf outputfilename) force) (let ((my-start-time (current-seconds)) (lockf (conc outputfilename ".lock"))) (let loop ((have-lock (common:simple-file-lock lockf))) (if have-lock (let ((script (configf:lookup *configdat* "testrollup" test-name))) | | | | 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 | (equal? logf outputfilename) force) (let ((my-start-time (current-seconds)) (lockf (conc outputfilename ".lock"))) (let loop ((have-lock (common:simple-file-lock lockf))) (if have-lock (let ((script (configf:lookup *configdat* "testrollup" test-name))) (debug:print 0 *default-log-port* "Obtained lock for " outputfilename) (rmt:set-state-status-and-roll-up-items run-id test-name "" #f #f #f) (if script (system (conc script " > " outputfilename " & ")) (tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename)) (common:simple-file-release-lock lockf) (change-directory orig-dir) ;; NB// tests:test-set-toplog! is remote internal... (tests:test-set-toplog! run-id test-name outputfilename)) ;; didn't get the lock, check to see if current update started later than this ;; update, if so we can exit without doing any work (if (> my-start-time (handle-exceptions exn (begin (debug:print 0 *default-log-port* "failed to get mod time on " lockf ", exn=" exn) 0) (file-modification-time lockf))) ;; we started since current re-gen in flight, delay a little and try again (begin (debug:print-info 1 *default-log-port* "Waiting to update " outputfilename ", another test currently updating it") (thread-sleep! (+ 5 (random 5))) ;; delay between 5 and 10 seconds (loop (common:simple-file-lock lockf)))))))))) |
︙ | ︙ | |||
594 595 596 597 598 599 600 | "<td>" (if (equal? comment "") " " comment) "</td>" "</tr>")))) (if (list? testdat) testdat (begin | | | 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 | "<td>" (if (equal? comment "") " " comment) "</td>" "</tr>")))) (if (list? testdat) testdat (begin (debug:print 0 *default-log-port* "ERROR: failed to get records with rmt:test-get-records-for-index-file run-id=" run-id "test-name=" test-name) '()))) (print "<table><tr><td valign=\"top\">") ;; Print out stats for status (set! tot 0) (print "<table cellspacing=\"0\" border=\"1\"><tr><td colspan=\"2\"><h2>State stats</h2></td></tr>") (for-each (lambda (state) |
︙ | ︙ | |||
907 908 909 910 911 912 913 | (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #f run-patt target-patt)) ;; update this function (close-output-port oup) ; (set! page (+ 1 page)) (if (> total-runs (* (+ 1 page) pg-size)) (loop (+ 1 page))))) (common:simple-file-release-lock lockfile)) (begin | | | 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 | (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #f run-patt target-patt)) ;; update this function (close-output-port oup) ; (set! page (+ 1 page)) (if (> total-runs (* (+ 1 page) pg-size)) (loop (+ 1 page))))) (common:simple-file-release-lock lockfile)) (begin (debug:print 0 *default-log-port* "Failed to get lock on file outf, lockfile: " lockfile) #f)))) (define (tests:readlines filename) (call-with-input-file filename (lambda (p) (let loop ((line (read-line p)) (result '())) |
︙ | ︙ | |||
1605 1606 1607 1608 1609 1610 1611 | #f) ( (and wait-a-minute (> tries-left 0)) (thread-sleep! 10) (debug:print 0 *default-log-port* "WARNING: testconfig file does not exist: "test-configf" will retry in 10 seconds. Tries left: "tries-left) ;; BB: this fires (loopa (sub1 tries-left))) (else | | | | 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 | #f) ( (and wait-a-minute (> tries-left 0)) (thread-sleep! 10) (debug:print 0 *default-log-port* "WARNING: testconfig file does not exist: "test-configf" will retry in 10 seconds. Tries left: "tries-left) ;; BB: this fires (loopa (sub1 tries-left))) (else (debug:print 2 *default-log-port* "WARNING: testconfig file does not exist: "test-configf) ;; BB: this fires #f)))) (tcfg (if testexists (read-config test-configf #f system-allowed environ-patt: (if system-allowed "pre-launch-env-vars" #f)) #f))) (if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data (if tcfg (hash-table-set! *testconfigs* test-full-name tcfg)) (if (and testexists cache-file (file-write-access? cache-path) allow-write-cache) (let ((tpath (conc cache-path "/.testconfig"))) (debug:print-info 2 *default-log-port* "Caching testconfig for " test-name " in " tpath) (if (and tcfg (not (common:in-running-test?))) (configf:write-alist tcfg tpath)))) tcfg)))))) ;; sort tests by priority and waiton ;; Move test specific stuff to a test unit FIXME one of these days (define (tests:sort-by-priority-and-waiton test-records) |
︙ | ︙ | |||
1699 1700 1701 1702 1703 1704 1705 | ;; (lambda (x)(equal? "node" (car x))) ;; (map string-split (tests:easy-dot test-records "plain")))))) ;; (map car (sort data (lambda (a b) ;; (> (string->number (caddr a))(string->number (caddr b))))))) ;; )) (sort all-tests sort-fn1)))) ;; avoid dealing with deleted tests, look at the hash table | < < < < < < < < < < < < < < < < < | < < | | 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 | ;; (lambda (x)(equal? "node" (car x))) ;; (map string-split (tests:easy-dot test-records "plain")))))) ;; (map car (sort data (lambda (a b) ;; (> (string->number (caddr a))(string->number (caddr b))))))) ;; )) (sort all-tests sort-fn1)))) ;; avoid dealing with deleted tests, look at the hash table (define (tests:easy-dot test-records outtype) (let-values (((fd temp-path) (file-mkstemp (conc "/tmp/" (current-user-name) ".XXXXXX")))) (let ((all-testnames (hash-table-keys test-records)) (temp-port (open-output-file* fd))) ;; (format temp-port "This file is ~A.~%" temp-path) (format temp-port "digraph tests {\n") (format temp-port " size=4,8\n") ;; (format temp-port " splines=none\n") (for-each (lambda (testname) (let* ((testrec (hash-table-ref test-records testname)) (waitons (or (tests:testqueue-get-waitons testrec) '()))) (for-each (lambda (waiton) (format temp-port (conc " " waiton " -> " testname " [splines=ortho]\n"))) waitons))) all-testnames) (format temp-port "}\n") (close-output-port temp-port) (with-input-from-pipe (conc "env -i PATH=$PATH dot -T" outtype " < " temp-path) (lambda () (let ((res (read-lines))) |
︙ | ︙ | |||
1762 1763 1764 1765 1766 1767 1768 | (tal (cdr all-testnames)) (res (list "digraph tests {" (conc " size=\"" (or sizex 11) "," (or sizey 11) "\";") " ratio=0.95;" ))) (let* ((testrec (hash-table-ref test-records hed)) (waitons (or (tests:testqueue-get-waitons testrec) '())) | < < | | | | < | | | | | | | | | | | | | < < < < < < | 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 | (tal (cdr all-testnames)) (res (list "digraph tests {" (conc " size=\"" (or sizex 11) "," (or sizey 11) "\";") " ratio=0.95;" ))) (let* ((testrec (hash-table-ref test-records hed)) (waitons (or (tests:testqueue-get-waitons testrec) '())) (newres (append res (if (null? waitons) (list (conc " \"" hed "\" [shape=box];")) (map (lambda (waiton) (conc " \"" waiton "\" -> \"" hed "\" [shape=box];")) waitons) )))) (if (null? tal) (append newres (list "}")) (loop (car tal)(cdr tal) newres) )))))) ;; (tests:run-dot (list "digraph tests {" "a -> b" "}") "plain") (define (tests:run-dot indat outtype) ;; outtype is plain, fig, dot, etc. http://www.graphviz.org/content/output-formats (let-values (((inp oup pid)(process "env -i PATH=\"$PATH\" dot" (list "-T" outtype)))) (with-output-to-port oup (lambda () (map print indat))) (close-output-port oup) (let ((res (with-input-from-port inp (lambda () (read-lines))))) (close-input-port inp) res))) ;; read data from tmp file or create if not exists ;; if exists regen in background ;; (define (tests:lazy-dot testrecords outtype sizex sizey) (let ((dfile (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dot")) (fname (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dotdat"))) (tests:write-dot-file testrecords dfile sizex sizey) (if (common:file-exists? fname) (let ((res (with-input-from-file fname (lambda () (read-lines))))) (system (conc "env -i PATH=\"$PATH\" dot -T " outtype " < " dfile " > " fname "&")) res) (begin (system (conc "env -i PATH=\"$PATH\" dot -T " outtype " < " dfile " > " fname)) (with-input-from-file fname (lambda () (read-lines))))))) ;; for each test: ;; (define (tests:filter-non-runnable run-id testkeynames testrecordshash) (let ((runnables '())) (for-each (lambda (testkeyname) |
︙ | ︙ | |||
1868 1869 1870 1871 1872 1873 1874 | ;;====================================================================== ;; refactoring this block into tests:get-full-data from line 263 of runs.scm ;;====================================================================== ;; hed is the test name ;; test-records is a hash of test-name => test record (define (tests:get-full-data test-names test-records required-tests all-tests-registry) | > | | | > > > > > > > > > > > > | | | 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 | ;;====================================================================== ;; refactoring this block into tests:get-full-data from line 263 of runs.scm ;;====================================================================== ;; hed is the test name ;; test-records is a hash of test-name => test record (define (tests:get-full-data test-names test-records required-tests all-tests-registry) (let ((missing-waitons (make-hash-table))) (if (not (null? test-names)) (let loop ((hed (car test-names)) (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc (debug:print-info 4 *default-log-port* "hed=" hed " at top of loop") ;; don't know item-path at this time, let the testconfig get the top level testconfig (let* ((config (tests:get-testconfig hed #f all-tests-registry 'return-procs)) (waitons (let ((instr (if config (configf:lookup config "requirements" "waiton") (begin ;; No config means this is a non-existent test (let ((waiters '())) ;; find the waiter(s) for this waiton. (for-each (lambda(waiter) ;; (print "test-record = " (hash-table-ref test-records waiter)) ;; (print "waitons = " (vector-ref (hash-table-ref test-records waiter) 2)) (if (member hed (vector-ref (hash-table-ref test-records waiter) 2)) (set! waiters (cons waiter waiters)) ) ) (hash-table-keys test-records)) (hash-table-set! missing-waitons hed waiters) ) "")))) (debug:print-info 8 *default-log-port* "waitons string is " instr) (string-split (cond ((procedure? instr) (let ((res (instr))) (debug:print-info 8 *default-log-port* "waiton procedure results in string " res " for test " hed) res)) ((string? instr) instr) (else ;; NOTE: This is actually the case of *no* waitons! ;; "")))))) (if (not config) ;; this is a non-existant test called in a waiton. (if (null? tal) test-records (loop (car tal)(cdr tal))) (begin (debug:print-info 8 *default-log-port* "waitons: " waitons) |
︙ | ︙ | |||
1936 1937 1938 1939 1940 1941 1942 | (debug:print-info 4 *default-log-port* "items and itemstable are lists, calc now\n" " items: " items " itemstable: " itemstable) (items:get-items-from-config config)) (else #f))) ;; not iterated #f ;; itemsdat 5 #f ;; spare - used for item-path ))) | | | | > > > > > > > > | | | < | < < < < < < < < < < < < < < < < < < < < | < < | | | | | | | > > > > > > > > | | | > > > > > > > > > > > > > > | | | 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 | (debug:print-info 4 *default-log-port* "items and itemstable are lists, calc now\n" " items: " items " itemstable: " itemstable) (items:get-items-from-config config)) (else #f))) ;; not iterated #f ;; itemsdat 5 #f ;; spare - used for item-path ))) (for-each (lambda (waiton) (if (and waiton (not (string= "#f" waiton)) (not (member waiton test-names))) (begin (set! required-tests (cons waiton required-tests)) (set! test-names (cons waiton test-names))))) ;; was an append, now a cons waitons) (let ((remtests (delete-duplicates (append waitons tal)))) (if (not (null? remtests)) (loop (car remtests)(cdr remtests)) test-records))))))) (for-each (lambda (missing-waiton) (debug:print-error 0 *default-log-port* "non-existent test \"" missing-waiton "\" is a waiton for tests " (hash-table-ref missing-waitons missing-waiton)) ) (hash-table-keys missing-waitons) ) )) ;;====================================================================== ;; test steps ;;====================================================================== ;; teststep-set-status! used to be here ;; NOT NEEDED #;(define (test-get-kill-request run-id test-id) ;; run-id test-name itemdat) (let* ((testdat (rmt:get-test-state-status-by-id run-id test-id))) (and testdat (equal? (car testdat) "KILLREQ")))) (define (test:tdb-get-rundat-count tdb) (if tdb (let ((res 0)) (sqlite3:for-each-row (lambda (count) (set! res count)) tdb "SELECT count(id) FROM test_rundat;") res)) 0) (define (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname) (rmt:general-call 'update-test-rundat run-id test-id (current-seconds) (or cpuload -1)(or diskfree -1) -1 (or minutes -1)) (if (and cpuload diskfree) (rmt:general-call 'update-cpuload-diskfree run-id cpuload diskfree test-id)) (if minutes (rmt:general-call 'update-run-duration run-id minutes test-id)) (if (and uname hostname) (rmt:general-call 'update-uname-host run-id uname hostname test-id))) ;; This one is for running with no db access (i.e. via rmt: internally) (define (tests:set-full-meta-info db test-id run-id minutes work-area remtries) ;; (define (tests:set-full-meta-info test-id run-id minutes work-area) ;; (let ((remtries 10)) (let* ((cpuload (commonmod:get-cpu-load)) (diskfree (get-df (current-directory))) (uname (get-uname "-srvpio")) (hostname (get-host-name))) (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname))) ;; (define (tests:set-partial-meta-info test-id run-id minutes work-area) #;(define (tests:set-partial-meta-info test-id run-id minutes work-area remtries) (let* ((cpuload (get-cpu-load)) (diskfree (get-df (current-directory))) (remtries 10)) (handle-exceptions exn (if (> remtries 0) (begin (print-call-chain (current-error-port)) (debug:print-info 0 *default-log-port* "WARNING: failed to set meta info. Will try " remtries " more times") (set! remtries (- remtries 1)) (thread-sleep! 10) (tests:set-full-meta-info db test-id run-id minutes work-area (- remtries 1))) (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) (debug:print-error 0 *default-log-port* "tried for over a minute to update meta info and failed. Giving up") (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable.") (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 5 *default-log-port* "exn=" (condition->list exn)) (debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn)) (print-call-chain (current-error-port)))) (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes) ))) ;;====================================================================== ;; A R C H I V I N G ;;====================================================================== (define (test:archive db test-id) #f) (define (test:archive-tests db keynames target) #f) |
Added tests/longruntest/Makefile version [d958b22b7d].
> > > > > | 1 2 3 4 5 | cleanup : killall mtest dboard -v -9 || true rm -rf *.log *.bak NB* logs/* .meta .db /tmp/$(USER)/megatest_localdb/simplerun ../simpleruns/* lt |
Added tests/longruntest/README version [2584179a27].
> | 1 | Super simple test system - useful for testing db access. |
Added tests/longruntest/megatest.config version [8e37510f96].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # Copyright 2006-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/>. [fields] SYSTEM TEXT RELEASE TEXT [setup] # Adjust max_concurrent_jobs to limit how much you load your machines max_concurrent_jobs 50 [server] timeout 3 # 3600 # Uncomment this to make the in-mem db into a disk based db (slower but good for debug) # be aware that some unit tests will fail with this due to persistent data # # tmpdb /tmp # This is your link path, you can move it but it is generally better to keep it stable linktree #{getenv MT_RUN_AREA_HOME}/../simplelinks # Valid values for state and status for steps, NB// It is not recommended you use this [validvalues] state start end completed # Job tools are more advanced ways to control how your jobs are launched [jobtools] # useshell yes launcher nbfake # You can override environment variables for all your tests here [env-override] EXAMPLE_VAR example value # As you run more tests you may need to add additional disks, the names are arbitrary but must be unique [disks] disk0 #{getenv MT_RUN_AREA_HOME}/../simpleruns |
Added tests/longruntest/runconfigs.config version [0ee129edcc].
> > > > > > > > > > > > > > > > > > > > > > > > | 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 2006-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/>. [default] ALLTESTS see this variable !GLOBAL_WAITONS runfirst # Your variables here are grouped by targets [SYSTEM/RELEASE] [SYSTEM_val/RELEASE_val] ANOTHERVAR only defined if target is SYSTEM_val/RELEASE_val |
Added tests/longruntest/test.config version [5d045ee29c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # Copyright 2006-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/>. [section1] 1 ./blah [section2] # A comment [disks] 1 ./ [validvalues] state start end aborted status pass fail n/a [include a file that doesn't exist] blah nada # now inlcude a file tha tdoes exist [include megatest.config] [metadata] description This is a multiline description. The leading whitespace is discarded irrespective of amount of indenting. This line is indented more. author matt lastreview never |
Added tests/longruntest/tests/runfirst/testconfig version [251adc4bf0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # Copyright 2006-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/>. # Add additional steps here. Format is "stepname script" [ezsteps] step1 step1.sh step2 step2.sh # Test requirements are specified here [requirements] # waiton setup priority 0 # Iteration for your tests are controlled by the items section [items] PARTOFDAY morning noon afternoon evening night [scripts] step1.sh #!/bin/bash sleep 1 step2.sh #!/bin/bash sleep 2 # test_meta is a section for storing additional data on your test [test_meta] author matt owner matt description An example test tags tagone,tagtwo reviewed never |
Added tests/longruntest/tests/test1/testconfig version [7f16870d29].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # Copyright 2006-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/>. # Add additional steps here. Format is "stepname script" [ezsteps] createsteps createsteps.sh [scripts] createsteps.sh #!/bin/bash (for x in $(seq 20);do echo "step$x sleep $x" done) > #{getenv MT_RUN_AREA_HOME}/steps.config [logpro] (expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) (expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) (expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/)) ;; but disallow any other errors # Test requirements are specified here [requirements] # waiton setup priority 0 # Iteration for your tests are controlled by the items section # [items] # PARTOFDAY morning noon afternoon evening night # test_meta is a section for storing additional data on your test [test_meta] author matt owner matt description An example test tags tagone,tagtwo reviewed never |
Added tests/longruntest/tests/test2/testconfig version [22cc5c5e80].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # Copyright 2006-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/>. # Add additional steps here. Format is "stepname script" [ezsteps] [include #{getenv MT_RUN_AREA_HOME}/steps.config] # Test requirements are specified here [requirements] waiton test1 priority 0 # Iteration for your tests are controlled by the items section [items] LANDTYPE desert [logpro] (expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) (expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) (expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/)) ;; but disallow any other errors # test_meta is a section for storing additional data on your test [test_meta] author matt owner matt description Yet another example test tags tagone,tagtwo,quick reviewed never |
Added tests/longruntest/withmt version [2714033fbb].
> > > > > | 1 2 3 4 5 | #!/bin/bash export PATH="$PWD/../../bin:$PATH" exec "$@" |
Added tests/simplerun/Makefile version [d958b22b7d].
> > > > > | 1 2 3 4 5 | cleanup : killall mtest dboard -v -9 || true rm -rf *.log *.bak NB* logs/* .meta .db /tmp/$(USER)/megatest_localdb/simplerun ../simpleruns/* lt |
Added tests/simplerun/debug.scm version [1bee670fb9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (module junk * (import big-chicken rmtmod apimod dbmod srfi-18 trace) (trace-call-sites #t) (trace ;; db:get-tests-for-run ;; rmt:general-open-connection ;; rmt:open-main-connection ;; rmt:drop-conn ;; rmt:send-receive ;; rmt:log-to-main ) (define (make-run-id) (let* ((s (conc (current-process-id))) (l (string-length s))) (string->number (substring s (- l 3) l)) )) (define (run) (let* ((th1 (make-thread (lambda () (let loop ((r 0) (i 1) (s 0)) ;; sum (let ((start-time (current-milliseconds)) (run-id (+ r (make-run-id)))) (rmt:register-test run-id "test1" (conc "item_" i)) (thread-sleep! 0.01) (let* ((qry-time (- (current-milliseconds) start-time)) (tot-query-time (+ qry-time s)) (avg-query-time (* 1.0 (/ tot-query-time (max i 1))))) (if (> qry-time 500) (print "WARNING: rmt:register-test took more than 500ms, "qry-time"ms, i="i", avg-query-time="avg-query-time)) (if (eq? (modulo i 100) 0) (print "For run-id="run-id", "(rmt:get-keys-write)" num tests registered="i" avg-query-time="avg-query-time)) (if (< i 500) (loop r (+ i 1) tot-query-time) (if (< r 100) (let* ((start-time (current-milliseconds))) (print "rmt:get-keys "(rmt:get-keys)" in "(- (current-milliseconds) start-time)) ;; run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode (print "Got "(length (rmt:get-tests-for-run run-id "%" '() '() #f #f #f #f #f #f 0 #f))" tests for run "run-id) (print "Average query time: "avg-query-time) (loop (+ r 1) 0 tot-query-time)))))))) ))) (thread-start! th1) (thread-join! th1))) (run) ) |
Modified tests/simplerun/megatest.config from [373cc8c0cf] to [8e37510f96].
︙ | ︙ | |||
18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | [fields] SYSTEM TEXT RELEASE TEXT [setup] # Adjust max_concurrent_jobs to limit how much you load your machines max_concurrent_jobs 50 # Uncomment this to make the in-mem db into a disk based db (slower but good for debug) # be aware that some unit tests will fail with this due to persistent data # # tmpdb /tmp # This is your link path, you can move it but it is generally better to keep it stable linktree #{getenv MT_RUN_AREA_HOME}/../simplelinks # Valid values for state and status for steps, NB// It is not recommended you use this [validvalues] state start end completed # Job tools are more advanced ways to control how your jobs are launched [jobtools] | > > > > | | | 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 | [fields] SYSTEM TEXT RELEASE TEXT [setup] # Adjust max_concurrent_jobs to limit how much you load your machines max_concurrent_jobs 50 [server] timeout 3 # 3600 # Uncomment this to make the in-mem db into a disk based db (slower but good for debug) # be aware that some unit tests will fail with this due to persistent data # # tmpdb /tmp # This is your link path, you can move it but it is generally better to keep it stable linktree #{getenv MT_RUN_AREA_HOME}/../simplelinks # Valid values for state and status for steps, NB// It is not recommended you use this [validvalues] state start end completed # Job tools are more advanced ways to control how your jobs are launched [jobtools] # useshell yes launcher nbfake # You can override environment variables for all your tests here [env-override] EXAMPLE_VAR example value # As you run more tests you may need to add additional disks, the names are arbitrary but must be unique [disks] disk0 #{getenv MT_RUN_AREA_HOME}/../simpleruns |
Modified tests/simplerun/runconfigs.config from [cd9421e89b] to [0ee129edcc].
︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 | # 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/>. [default] ALLTESTS see this variable # Your variables here are grouped by targets [SYSTEM/RELEASE] [SYSTEM_val/RELEASE_val] ANOTHERVAR only defined if target is SYSTEM_val/RELEASE_val | > | 13 14 15 16 17 18 19 20 21 22 23 24 | # 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/>. [default] ALLTESTS see this variable !GLOBAL_WAITONS runfirst # Your variables here are grouped by targets [SYSTEM/RELEASE] [SYSTEM_val/RELEASE_val] ANOTHERVAR only defined if target is SYSTEM_val/RELEASE_val |
Added tests/simplerun/tests/runfirst/testconfig version [251adc4bf0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # Copyright 2006-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/>. # Add additional steps here. Format is "stepname script" [ezsteps] step1 step1.sh step2 step2.sh # Test requirements are specified here [requirements] # waiton setup priority 0 # Iteration for your tests are controlled by the items section [items] PARTOFDAY morning noon afternoon evening night [scripts] step1.sh #!/bin/bash sleep 1 step2.sh #!/bin/bash sleep 2 # test_meta is a section for storing additional data on your test [test_meta] author matt owner matt description An example test tags tagone,tagtwo reviewed never |
Modified tests/simplerun/tests/test1/testconfig from [db2c27ffef] to [b9db33e554].
︙ | ︙ | |||
22 23 24 25 26 27 28 | # Test requirements are specified here [requirements] # waiton setup priority 0 # Iteration for your tests are controlled by the items section | | | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | # Test requirements are specified here [requirements] # waiton setup priority 0 # Iteration for your tests are controlled by the items section # [items] # PARTOFDAY morning noon afternoon evening night # test_meta is a section for storing additional data on your test [test_meta] author matt owner matt description An example test |
︙ | ︙ |
Added tests/simplerun/thebeginning.scm version [43c4eb8711].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (use trace test (prefix sqlite3 sqlite3:)) (import dbfile) (trace-call-sites #t) (trace ;; dbfile:setup ;; dbfile:open-sqlite3-db ;; dbfile:init-subdb ;; dbfile:add-dbdat ;; db:initialize-main-db ;; dbfile:set-subdb ;; db:with-db ;; dbfile:get-subdb ) (system "touch /tmp/mmgraham/megatest_localdb/simplerun/.nfs.pdx.disks.icf_gwa_001.mmgraham.fossil.megatest1.7.mod.tests.simplerun/.db/10.db") ;; *************** dbfile.scm tests **************** ;; (debug:print 0 *default-log-port* " tmp area: " (common:get-db-tmp-area)) (define tmpdir (common:get-db-tmp-area)) (test #f #t (dbr:dbstruct? (dbfile:setup #t *toppath* tmpdir))) (test #f #t (dbr:dbstruct? (db:setup #t))) (define dbstruct *dbstruct-dbs*) ;; (test #f #t (dbr:subdb? (dbfile:init-subdb dbstruct #f db:initialize-main-db))) ;; this opens the nfs main db ;; (test #f #t (dbr:dbdat? (dbfile:open-db *dbstruct-dbs* #f db:initialize-main-db))) ;; this opens the tmp db. ;; (define maindbdat (dbfile:open-db *dbstruct-dbs* #f db:initialize-main-db)) ;; this opens the tmp db. ;; (dbfile:add-dbdat dbstruct #f maindbdat) ;;(test #f #t (dbr:subdb? (dbfile:get-subdb dbstruct #f))) ;; (test #f #t (dbr:dbdat? (dbfile:get-dbdat dbstruct #f))) ;; (test #f #f (dbr:dbdat? (dbfile:get-dbdat dbstruct #f))) ;; stack empty so should fail. ;; (test #f #t (hash-table? (dbr:dbstruct-subdbs dbstruct))) ;; (test #f #t (stack? (dbr:subdb-dbstack (dbfile:get-subdb dbstruct #f)))) ;; (test #f '("SYSTEM" "RELEASE") (db:get-keys *dbstruct-dbs*)) ;; (test #f #t (dbr:dbdat? (dbfile:open-db dbstruct 1 db:initialize-main-db))) ;; (test #f #t (dbr:dbdat? (dbfile:open-db dbstruct 2 db:initialize-main-db))) ;; (define rundbdat (dbfile:open-db dbstruct 1 db:initialize-main-db)) ;; (define rundbdat2 (dbfile:open-db dbstruct 2 db:initialize-main-db)) ;; (define rundbdat3 (dbfile:open-db dbstruct 3 db:initialize-main-db)) ;; (dbfile:add-dbdat dbstruct 1 rundbdat) ;; (dbfile:add-dbdat dbstruct 2 rundbdat2) ;; (dbfile:add-dbdat dbstruct 3 rundbdat3) ;; (test #f #t (dbr:subdb? (dbfile:get-subdb dbstruct 1))) ;; (test #f #t (dbr:dbdat? (dbfile:get-dbdat dbstruct 1))) ;; (test #f #t (dbr:subdb? (dbfile:get-subdb dbstruct 2))) ;; (test #f #t (dbr:dbdat? (dbfile:get-dbdat dbstruct 2))) ;; (test #f #t (> (dbfile:lazy-sqlite-db-modification-time ".db/main.db") 0)) ;; (test #f #t (> (dbfile:lazy-sqlite-db-modification-time ".db/1.db") 0)) ;; (test #f #t (> (dbfile:lazy-sqlite-db-modification-time ".db/2.db") 0)) ;; (test #f #t (common:simple-file-lock "./db.lock")) ;; (test #f "./db.lock" (common:simple-file-release-lock "./db.lock")) ;; *************** db.scm tests **************** ;; (define thisdbdat (db:open-db dbstruct #f)) ;; (test #f #t (dbr:dbdat? thisdbdat)) ;; (test #f #t (dbr:dbdat? (db:get-db dbstruct #f))) ;; (test #f #t (dbr:dbdat? (db:get-db dbstruct 1))) ;; (test #f #t (dbr:dbdat? (db:get-db dbstruct 2))) ;; (dbfile:add-dbdat dbstruct #f maindbdat) ;; (define maindbdat (dbfile:get-dbdat dbstruct #f)) ;; (dbfile:add-dbdat dbstruct #f maindbdat) ;; (define mtdbdat2 (dbr:subdb-mtdbdat (dbfile:get-subdb dbstruct #f))) ;; (define areapath (dbr:dbstruct-areapath dbstruct)) ;; (define mtdbpath (dbfile:run-id->path areapath #f)) ;; (define init-proc db:initialize-main-db) ;; (define mtdbdat (dbfile:open-sqlite3-db mtdbpath init-proc)) ;; (define maindb-handle (dbr:dbdat-dbh mtdbdat)) ;; (define maindb-handle2 (dbr:dbdat-dbh mtdbdat2)) ;; (sqlite3:execute maindb-handle "vacuum") ;; (sqlite3:execute maindb-handle2 "vacuum") ;; (define full-sel (conc "SELECT * from runs")) ;; (sqlite3:for-each-row ;; (lambda (a . b) ;; (debug:print 0 *default-log-port* "a: " a " b: " b) ;; ) ;; maindb-handle ;; full-sel) ;; (test #f #t (db:sync-touched dbstruct #f)) ;; (test #f #t (db:sync-touched dbstruct 1)) ;; (test #f #t (db:sync-touched dbstruct 2)) ;; (test #f #t (dbr:subdb? (dbfile:get-subdb dbstruct #f))) ;; (test #f #t (dbr:subdb? (dbfile:get-subdb dbstruct (string->number "1")))) ;; (test #f #t (dbr:subdb? (dbfile:get-subdb dbstruct 2))) ;; (test #f #t (db:sync-touched dbstruct #f)) ;; (test #f #t (db:sync-touched dbstruct 1)) ;; (test #f #t (db:sync-touched dbstruct 2)) (test #f #t (db:all-db-sync dbstruct)) (exit) ;; (test #f #t (db:close-all dbstruct)) (test #f #t (db:safely-close-sqlite3-db (dbr:dbdat-dbh rundbdat) (dbr:dbdat-stmt-cache rundbdat))) (test #f #t (db:safely-close-sqlite3-db (dbr:dbdat-dbh rundbdat2) (dbr:dbdat-stmt-cache rundbdat2))) (test #f #t (db:safely-close-sqlite3-db (dbr:dbdat-dbh mtdbdat) (dbr:dbdat-stmt-cache mtdbdat))) |
Modified tests/unittests/all-api.scm from [52fe593b26] to [60bcb491ab].
︙ | ︙ | |||
114 115 116 117 118 119 120 | (test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'register-run (list '(("SYSTEM" "ubuntu")("RELEASE" "v1.234")) "bar" "NEW" "JUSTFINE" "bobafett" "quick" ))) 0)) (test #f #(#t "bar") (api:execute-requests my-dbstruct (vector 'get-run-name-from-id '(1)))) (test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'delete-run (list 2))) 0)) ;; delete a non-existant run (test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'update-run-stats (list 1 '()))) 0)) (test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-main-run-stats (list 1 ))) 0)) (test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'delete-old-deleted-test-records '())) 0)) (test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-runs (list "%" 10 0 keypatts))) 0)) | | | 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 | (test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'register-run (list '(("SYSTEM" "ubuntu")("RELEASE" "v1.234")) "bar" "NEW" "JUSTFINE" "bobafett" "quick" ))) 0)) (test #f #(#t "bar") (api:execute-requests my-dbstruct (vector 'get-run-name-from-id '(1)))) (test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'delete-run (list 2))) 0)) ;; delete a non-existant run (test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'update-run-stats (list 1 '()))) 0)) (test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-main-run-stats (list 1 ))) 0)) (test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'delete-old-deleted-test-records '())) 0)) (test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-runs (list "%" 10 0 keypatts))) 0)) (test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'simple-get-runs (list "%" 10 0 keypatts))) 0)) (test #f #(#t (1))(api:execute-requests my-dbstruct (vector 'get-all-run-ids '()))) (test #f #(#t ()) (api:execute-requests my-dbstruct (vector 'get-prev-run-ids '(1)))) (test #f #(#t "JUSTFINE") (api:execute-requests my-dbstruct (vector 'get-run-status '(1)))) (test #f #(#t "NEW") (api:execute-requests my-dbstruct (vector 'get-run-state '(1)))) (test #f #(#t (("Totals" "UNKNOWN" 1) ("bar" "UNKNOWN" 1))) (api:execute-requests my-dbstruct (vector 'get-run-stats '()))) (test #f #(#t ()) (api:execute-requests my-dbstruct (vector 'get-run-times '(1 1 )))) (test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'lock/unlock-run '(1 #t #f "mikey"))) 0)) |
︙ | ︙ |
Modified tests/unittests/all-rmt.scm from [2e51ccf329] to [3c7b17d5c4].
︙ | ︙ | |||
36 37 38 39 40 41 42 | (define toppath (current-directory)) (test #f #f (server:check-if-running toppath)) ;; these are used by server:start-and-wait (test #f #t (list? (server:get-list toppath))) (test #f '() (server:get-best '())) (test #f #t (common:simple-file-lock-and-wait "test.lock" expire-time: 15)) (test #f "test.lock" (common:simple-file-release-lock "test.lock")) | | | | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 | (define toppath (current-directory)) (test #f #f (server:check-if-running toppath)) ;; these are used by server:start-and-wait (test #f #t (list? (server:get-list toppath))) (test #f '() (server:get-best '())) (test #f #t (common:simple-file-lock-and-wait "test.lock" expire-time: 15)) (test #f "test.lock" (common:simple-file-release-lock "test.lock")) (test #f #t (server:get-best-guess-address (get-host-name))) (test #f #t (string? (common:get-homehost))) ;; clean out any old running servers ;; (let ((servers (server:get-list toppath))) (print "Known servers: " servers) (if (not (null? servers)) (begin |
︙ | ︙ | |||
66 67 68 69 70 71 72 | ;; let's start up a server the mechanical way (system "nbfake megatest -server -") (thread-sleep! 2) ;; (test #f #t (string? (server:start-and-wait *toppath*))) (test "setup for run" #t (begin (launch:setup) (string? (getenv "MT_RUN_AREA_HOME")))) | | | 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 | ;; let's start up a server the mechanical way (system "nbfake megatest -server -") (thread-sleep! 2) ;; (test #f #t (string? (server:start-and-wait *toppath*))) (test "setup for run" #t (begin (launch:setup) (string? (getenv "MT_RUN_AREA_HOME")))) (test #f #t (client:setup-http toppath)) (test #f #t (vector? (client:setup toppath))) (test #f #t (vector? (rmt:get-connection-info toppath))) ;; TODO: push areapath down. (test #f #t (string? (server:check-if-running "."))) ;; DEF (test #f #f (rmt:send-receive-no-auto-client-setup *runremote* 'get-keys #f '())) ;; DEF (rmt:kill-server run-id) ;; DEF (rmt:start-server run-id) |
︙ | ︙ |
Added transport-mode.scm version [9dbf69644d].
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | ;;====================================================================== ;; set up transport, db cache and sync methods ;; ;; sync-method: 'original, 'attach or 'none ;; cache-method: 'tmp 'none ;; rmt:transport-mode: 'http, 'tcp, 'nfs ;; ;; NOTE: NOT ALL COMBINATIONS WORK ;; ;;====================================================================== ;; uncomment this block to test without tcp ;; (dbfile:sync-method 'none) ;; (dbfile:cache-method 'none) ;; (rmt:transport-mode 'nfs) ;; uncomment this block to test with tcp (dbfile:sync-method 'attach) ;; attach) ;; original (dbfile:cache-method 'tmp) (rmt:transport-mode 'tcp) |
Added transport-mode.scm.template version [9dbf69644d].
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | ;;====================================================================== ;; set up transport, db cache and sync methods ;; ;; sync-method: 'original, 'attach or 'none ;; cache-method: 'tmp 'none ;; rmt:transport-mode: 'http, 'tcp, 'nfs ;; ;; NOTE: NOT ALL COMBINATIONS WORK ;; ;;====================================================================== ;; uncomment this block to test without tcp ;; (dbfile:sync-method 'none) ;; (dbfile:cache-method 'none) ;; (rmt:transport-mode 'nfs) ;; uncomment this block to test with tcp (dbfile:sync-method 'attach) ;; attach) ;; original (dbfile:cache-method 'tmp) (rmt:transport-mode 'tcp) |
Modified tree.scm from [5b84d6f782] to [c8bcf1dc7e].
︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | ;; 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/>. ;; ;;====================================================================== (use format) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) (use sqlite3 srfi-1 posix regex regex-case srfi-69) (import (prefix sqlite3 sqlite3:)) | > > > > > > > > > < | < < < | < < < | 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 | ;; 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 tree)) (declare (uses mtargs)) (declare (uses debugprint)) (declare (uses launch)) (declare (uses gutils)) (declare (uses db)) (declare (uses server)) (declare (uses dcommon)) (use format) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) (use sqlite3 srfi-1 posix regex regex-case srfi-69) (import (prefix sqlite3 sqlite3:)) (import (prefix mtargs args:) debugprint) (include "megatest-version.scm") (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") ;;====================================================================== |
︙ | ︙ | |||
83 84 85 86 87 88 89 | (string-match "^\\s*$" curr-top)) (iup:attribute-set! obj "ADDBRANCH0" top)) (cond ((not (equal? top (iup:attribute obj "TITLE0"))) | | | 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 | (string-match "^\\s*$" curr-top)) (iup:attribute-set! obj "ADDBRANCH0" top)) (cond ((not (equal? top (iup:attribute obj "TITLE0"))) (debug:print 0 *default-log-port* "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0"))) ((null? nodelst)) (else (let loop ((hed (car nodelst)) (tal (cdr nodelst)) (depth 1) (pathl (list top))) ;; Because the tree dialog changes node numbers when |
︙ | ︙ | |||
129 130 131 132 133 134 135 | (if (>= currnode nodenum) newpath (loop (+ currnode 1) newpath))))) (define (tree:delete-node obj top node-path) ;; node-path is a list of strings (let ((id (tree:find-node obj (cons top node-path)))) | | | 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 | (if (>= currnode nodenum) newpath (loop (+ currnode 1) newpath))))) (define (tree:delete-node obj top node-path) ;; node-path is a list of strings (let ((id (tree:find-node obj (cons top node-path)))) (debug:print 0 *default-log-port* "Found node to remove " id " for path " top " " node-path) (iup:attribute-set! obj (conc "DELNODE" id) "SELECTED"))) #| (let* ((tb (iup:treebox #:value 0 #:name "Runs" |
︙ | ︙ |
Deleted ulex.scm version [39353b5283].
|
| < < < < < < < < < < < < < < < < < < < < < < < < |
Added ulex/dbmgr.scm version [afcee6ee9f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;;====================================================================== ;; Copyright 2022, 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 dbmgrmod)) (declare (uses ulex)) (declare (uses apimod)) (declare (uses pkts)) (declare (uses commonmod)) (declare (uses dbmod)) (declare (uses mtargs)) (declare (uses portloggermod)) (declare (uses debugprint)) (module dbmgrmod * (import scheme chicken.base chicken.condition chicken.file chicken.format chicken.port chicken.process chicken.process-context chicken.process-context.posix chicken.sort chicken.string chicken.time (prefix sqlite3 sqlite3:) matchable md5 message-digest regex s11n srfi-1 srfi-18 srfi-69 system-information typed-records pkts ulex commonmod apimod dbmod debugprint (prefix mtargs args:) portloggermod ) ;; Configurations for server ;; (tcp-buffer-size 2048) ;; (max-connections 2048) ;; info about me as a listener and my connections to db servers ;; stored (for now) in *db-serv-info* ;; (defstruct servdat (host #f) (port #f) (uuid #f) (dbfile #f) (uconn #f) ;; this is the listener *FOR THIS PROCESS* (mode #f) (status 'starting) (trynum 0) ;; count the number of ports we've tried (conns (make-hash-table)) ;; apath/dbname => conndat ) (define *db-serv-info* (make-servdat)) (define (servdat->url sdat) (conc (servdat-host sdat)":"(servdat-port sdat))) ;; db servers contact info ;; (defstruct conndat (apath #f) (dbname #f) (fullname #f) (hostport #f) (ipaddr #f) (port #f) (srvpkt #f) (srvkey #f) (lastmsg 0) (expires 0)) (define *srvpktspec* `((server (host . h) (port . p) (servkey . k) (pid . i) (ipaddr . a) (dbpath . d)))) ;;====================================================================== ;; S U P P O R T F U N C T I O N S ;;====================================================================== ;; set up the api proc, seems like there should be a better place for this? ;; ;; IS THIS NEEDED ANYMORE? TODO - REMOVE IF POSSIBLE ;; ;; (define api-proc (make-parameter conc)) ;; (api-proc api:execute-requests) ;; do we have a connection to apath dbname and ;; is it not expired? then return it ;; ;; else setup a connection ;; ;; if that fails, return '(#f "some reason") ;; NB// convert to raising an exception ;; (define (rmt:get-conn remdat apath dbname) (let* ((fullname (db:dbname->path apath dbname))) (hash-table-ref/default (servdat-conns remdat) fullname #f))) (define (rmt:drop-conn remdat apath dbname) (let* ((fullname (db:dbname->path apath dbname))) (hash-table-delete! (servdat-conns remdat) fullname))) (define (rmt:find-main-server uconn apath dbname) (let* ((pktsdir (get-pkts-dir apath)) (all-srvpkts (get-all-server-pkts pktsdir *srvpktspec*)) (viable-srvs (get-viable-servers all-srvpkts dbname))) (get-the-server uconn apath viable-srvs))) (define *connstart-mutex* (make-mutex)) (define *last-main-start* 0) ;; looks for a connection to main, returns if have and not exired ;; creates new otherwise ;; ;; connections for other servers happens by requesting from main ;; ;; TODO: This is unnecessarily re-creating the record in the hash table ;; (define (rmt:open-main-connection remdat apath) (let* ((fullpath (db:dbname->path apath ".db/main.db")) (conns (servdat-conns remdat)) (conn (rmt:get-conn remdat apath ".db/main.db")) ;; (hash-table-ref/default conns fullpath #f)) ;; TODO - create call for this (start-rmt:run (lambda () (let* ((th1 (make-thread (lambda ()(rmt:run (get-host-name))) "non-db mode server"))) (thread-start! th1) (thread-sleep! 1) (let loop ((count 0)) (assert (< count 30) "FATAL: responder failed to initialize in rmt:open-main-connection") (if (or (not *db-serv-info*) (not (servdat-uconn *db-serv-info*))) (begin (thread-sleep! 1) (loop (+ count 1))) (begin (servdat-mode-set! *db-serv-info* 'non-db) (servdat-uconn *db-serv-info*))))))) (myconn (servdat-uconn *db-serv-info*))) (cond ((not myconn) (start-rmt:run) (rmt:open-main-connection remdat apath)) ((and conn ;; conn is NOT a socket, just saying ... (< (current-seconds) (conndat-expires conn))) #t) ;; we are current and good to go - we'll deal elsewhere with a server that was killed or died ((and conn (>= (current-seconds)(conndat-expires conn))) (debug:print-info 0 *default-log-port* "connection to "fullpath" server expired. Reconnecting.") (rmt:drop-conn remdat apath ".db/main.db") ;; (rmt:open-main-connection remdat apath)) (else ;; Below we will find or create and connect to main (debug:print-info 0 *default-log-port* "rmt:open-main-connection - starting from scratch") (let* ((dbname (db:run-id->dbname #f)) (the-srv (rmt:find-main-server myconn apath dbname)) (start-main-srv (lambda () ;; call IF there is no the-srv found (mutex-lock! *connstart-mutex*) (if (> (- (current-seconds) *last-main-start*) 5) ;; at least four seconds since last attempt to start main server (begin (api:run-server-process apath dbname) (set! *last-main-start* (current-seconds)) (thread-sleep! 1)) (thread-sleep! 0.25)) (mutex-unlock! *connstart-mutex*) (rmt:open-main-connection remdat apath) ;; TODO: Add limit to number of tries ))) (if (not the-srv) ;; have server, try connecting to it (start-main-srv) (let* ((srv-addr (server-address the-srv)) ;; need serv (ipaddr (alist-ref 'ipaddr the-srv)) (port (alist-ref 'port the-srv)) (srvkey (alist-ref 'servkey the-srv)) (fullpath (db:dbname->path apath dbname)) (new-the-srv (make-conndat apath: apath dbname: dbname fullname: fullpath hostport: srv-addr ;; socket: (open-nn-connection srv-addr) - TODO - open ulex connection? ipaddr: ipaddr port: port srvpkt: the-srv srvkey: srvkey ;; generated by rmt:get-signature on the server side lastmsg: (current-seconds) expires: (+ (current-seconds) (server:expiration-timeout) -2) ;; this needs to be gathered during the ping ))) (hash-table-set! conns fullpath new-the-srv))) #t))))) ;; NB// sinfo is a servdat struct ;; (define (rmt:general-open-connection sinfo apath dbname #!key (num-tries 5)) (assert (not (equal? dbname ".db/main.db")) "ERROR: general-open-connection should never be called with main as the db") (let* ((mdbname ".db/main.db") ;; (db:run-id->dbname #f)) TODO: put this back to the lookup when stable (fullname (db:dbname->path apath dbname)) (conns (servdat-conns sinfo)) (mconn (rmt:get-conn sinfo apath ".db/main.db")) (dconn (rmt:get-conn sinfo apath dbname))) #;(if (and mconn (not (debug:print-logger))) (begin (debug:print-info 0 *default-log-port* "Turning on logging to main, look in logs dir for main log.") (debug:print-logger rmt:log-to-main))) (cond ((and mconn dconn (< (current-seconds)(conndat-expires dconn))) #t) ;; good to go ((not mconn) ;; no channel open to main? open it... (rmt:open-main-connection sinfo apath) (rmt:general-open-connection sinfo apath dbname num-tries: (- num-tries 1))) ((not dconn) ;; no channel open to dbname? (let* ((res (rmt:send-receive-real sinfo apath mdbname 'get-server `(,apath ,dbname)))) (case res ((server-started) (if (> num-tries 0) (begin (thread-sleep! 2) (rmt:general-open-connection sinfo apath dbname num-tries: (- num-tries 1))) (begin (debug:print-error 0 *default-log-port* "Failed to start servers needed or open channel to "apath", "dbname) (exit 1)))) (else (if (list? res) ;; server has been registered and the info was returned. pass it on. (begin ;; ("192.168.0.9" 53817 ;; "5e34239f48e8973b3813221e54701a01" "24310" ;; "192.168.0.9" ;; "/home/matt/data/megatest/tests/simplerun" ;; ".db/1.db") (match res ((host port servkey pid ipaddr apath dbname) (debug:print-info 0 *default-log-port* "got "res) (hash-table-set! conns fullname (make-conndat apath: apath dbname: dbname hostport: (conc host":"port) ;; socket: (open-nn-connection (conc host":"port)) ;; TODO - open ulex connection? ipaddr: ipaddr port: port srvkey: servkey lastmsg: (current-seconds) expires: (+ (current-seconds) (server:expiration-timeout) -2)))) (else (debug:print-info 0 *default-log-port* "return data from starting server did not match host port servkey pid ipaddr apath dbname " res))) res) (begin (debug:print-info 0 *default-log-port* "Unexpected result: " res) res))))))) #t)) ;;====================================================================== ;; FOR DEBUGGING SET TO #t ;; (define *localmode* #t) (define *localmode* #f) (define *dbstruct* (make-dbr:dbstruct)) ;; Defaults to current area ;; (define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) (let* ((apath *toppath*) (sinfo *db-serv-info*) (dbname (db:run-id->dbname rid))) (if *localmode* (api:execute-requests *dbstruct* cmd params) (begin (rmt:open-main-connection sinfo apath) (if rid (rmt:general-open-connection sinfo apath dbname)) #;(if (not (member cmd '(log-to-main))) (debug:print-info 0 *default-log-port* "rmt:send-receive "cmd" params="params)) (rmt:send-receive-real sinfo apath dbname cmd params))))) ;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed ;; sometime in the future ;; (define (rmt:send-receive-real sinfo apath dbname cmd params) (assert (not (eq? 'primordial (thread-name (current-thread)))) "FATAL: Do not call rmt:send-receive-real in the primodial thread.") (let* ((cdat (rmt:get-conn sinfo apath dbname))) (assert cdat "FATAL: rmt:send-receive-real called without the needed channels opened") (let* ((uconn (servdat-uconn sinfo)) ;; get the interface to ulex ;; then send-receive using the ulex layer to host-port stored in cdat (res (send-receive uconn (conndat-hostport cdat) cmd params)) #;(th1 (make-thread (lambda () (set! res (send-receive uconn (conndat-hostport cdat) cmd params))) "send-receive thread"))) ;; (thread-start! th1) ;; (thread-join! th1) ;; gratuitious thread stuff is so that mailbox is not used in primordial thead ;; since we accessed the server we can bump the expires time up (conndat-expires-set! cdat (+ (current-seconds) (server:expiration-timeout) -10)) ;; ten second margin for network time misalignments etc. res))) ;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed ;; sometime in the future. ;; ;; Purpose - call the main.db server and request a server be started ;; for the given area path and dbname ;; (define (rmt:print-db-stats) (let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f" (debug:print 18 *default-log-port* "DB Stats, "(seconds->year-week/day-time (current-seconds))"\n=====================") (debug:print 18 *default-log-port* (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg")) (for-each (lambda (cmd) (let ((cmd-dat (hash-table-ref *db-stats* cmd))) (debug:print 18 *default-log-port* (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0)))))) (sort (hash-table-keys *db-stats*) (lambda (a b) (> (vector-ref (hash-table-ref *db-stats* a) 0) (vector-ref (hash-table-ref *db-stats* b) 0))))))) (define (rmt:get-max-query-average run-id) (mutex-lock! *db-stats-mutex*) (let* ((runkey (conc "run-id=" run-id " ")) (cmds (filter (lambda (x) (substring-index runkey x)) (hash-table-keys *db-stats*))) (res (if (null? cmds) (cons 'none 0) (let loop ((cmd (car cmds)) (tal (cdr cmds)) (max-cmd (car cmds)) (res 0)) (let* ((cmd-dat (hash-table-ref *db-stats* cmd)) (tot (vector-ref cmd-dat 0)) (curravg (/ (vector-ref cmd-dat 1) (vector-ref cmd-dat 0))) ;; count is never zero by construction (currmax (max res curravg)) (newmax-cmd (if (> curravg res) cmd max-cmd))) (if (null? tal) (if (> tot 10) (cons newmax-cmd currmax) (cons 'none 0)) (loop (car tal)(cdr tal) newmax-cmd currmax))))))) (mutex-unlock! *db-stats-mutex*) res)) ;; host and port are used to ensure we are remove proper records (define (rmt:server-shutdown host port) (let ((dbfile (servdat-dbfile *db-serv-info*))) (debug:print-info 0 *default-log-port* "dbfile is "dbfile) (if dbfile (let* ((am-server (args:get-arg "-server")) (dbfile (args:get-arg "-db")) (apath *toppath*) #;(sinfo *remotedat*)) ;; foundation for future fix (if *dbstruct-db* (let* ((dbdat (db:get-dbdat *dbstruct-db* apath dbfile)) (db (dbr:dbdat-db dbdat)) (inmem (dbr:dbdat-db dbdat)) ;; WRONG ) ;; do a final sync here (debug:print-info 0 *default-log-port* "Doing final sync for "apath" "dbfile" at "(current-seconds)) (db:sync-inmem->disk *dbstruct-db* apath dbfile force-sync: #t) ;; let's finalize here (debug:print-info 0 *default-log-port* "Finalizing db and inmem") (if (sqlite3:database? db) (sqlite3:finalize! db) (debug:print-info 0 *default-log-port* "in rmt:server-shutdown, db is not a database, not finalizing...")) (if (sqlite3:database? inmem) (sqlite3:finalize! inmem) (debug:print-info 0 *default-log-port* "in rmt:server-shutdown, inmem is not a database, not finalizing...")) (debug:print-info 0 *default-log-port* "Finalizing db and inmem complete")) (debug:print-info 0 *default-log-port* "Db was never opened, no cleanup to do.")) (if (not am-server) (debug:print-info 0 *default-log-port* "I am not a server, should NOT get here!") (if (string-match ".*/main.db$" dbfile) (let ((pkt-file (conc (get-pkts-dir *toppath*) "/" (servdat-uuid *db-serv-info*) ".pkt"))) (debug:print-info 0 *default-log-port* "removing pkt "pkt-file) (delete-file* pkt-file) (debug:print-info 0 *default-log-port* "Releasing lock (if any) for "dbfile ", host "host", port "port) (db:with-lock-db (servdat-dbfile *db-serv-info*) (lambda (dbh dbfile) (db:release-lock dbh dbfile host port)))) ;; I'm not the server - should not have a lock to remove (let* ((sdat *db-serv-info*) ;; we have a run-id server (host (servdat-host sdat)) (port (servdat-port sdat)) (uuid (servdat-uuid sdat)) (res (rmt:deregister-server *db-serv-info* *toppath* host port uuid dbfile))) (debug:print-info 0 *default-log-port* "deregistered-server, res="res) (debug:print-info 0 *default-log-port* "deregistering server "host":"port" with uuid "uuid) ))))))) (define (common:run-sync?) ;; (and (common:on-homehost?) (args:get-arg "-server")) (define *rmt:run-mutex* (make-mutex)) (define *rmt:run-flag* #f) ;; Main entry point to start a server. was start-server (define (rmt:run hostn) (mutex-lock! *rmt:run-mutex*) (if *rmt:run-flag* (begin (debug:print-warn 0 *default-log-port* "rmt:run already running.") (mutex-unlock! *rmt:run-mutex*)) (begin (set! *rmt:run-flag* #t) (mutex-unlock! *rmt:run-mutex*) ;; ;; Configurations for server ;; (tcp-buffer-size 2048) ;; (max-connections 2048) (debug:print 2 *default-log-port* "PID: "(current-process-id)". Attempting to start the server ...") (if (and *db-serv-info* (servdat-uconn *db-serv-info*)) (let* ((uconn (servdat-uconn *db-serv-info*))) (wait-and-close uconn)) (let* ((port (portlogger:open-run-close portlogger:find-port)) (handler-proc (lambda (rem-host-port qrykey cmd params) ;; (set! *db-last-access* (current-seconds)) (assert (list? params) "FATAL: handler called with non-list params") (assert (args:get-arg "-server") "FATAL: handler called on non-server side. cmd="cmd", params="params) (debug:print 0 *default-log-port* "handler call: "cmd", params="params) (api:execute-requests *dbstruct-db* cmd params)))) ;; (api:process-request *dbstuct-db* (if (not *db-serv-info*) (set! *db-serv-info* (make-servdat host: hostn port: port))) (let* ((uconn (run-listener handler-proc port)) (rport (udat-port uconn))) ;; the real port (servdat-host-set! *db-serv-info* hostn) (servdat-port-set! *db-serv-info* rport) (servdat-uconn-set! *db-serv-info* uconn) (wait-and-close uconn) (db:print-current-query-stats) ))) (let* ((host (servdat-host *db-serv-info*)) (port (servdat-port *db-serv-info*)) (mode (or (servdat-mode *db-serv-info*) "non-db"))) ;; server exit stuff here ;; (rmt:server-shutdown host port) - always do in on-exit ;; (portlogger:open-run-close portlogger:set-port port "released") ;; moved to on-exit (debug:print-info 0 *default-log-port* "Server "host":"port" mode "mode"shutdown complete. Exiting") )))) ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== ;;====================================================================== ;; NEW SERVER METHOD ;;====================================================================== ;; only use for main.db - need to re-write some of this :( ;; (define (get-lock-db sdat dbfile host port) (assert host "FATAL: get-lock-db called with host not set.") (assert port "FATAL: get-lock-db called with port not set.") (let* ((dbh (db:open-run-db dbfile db:initialize-db)) ;; open-run-db creates a standard db with schema used by all situations (res (db:get-iam-server-lock dbh dbfile host port)) (uconn (servdat-uconn sdat))) ;; res => list then already locked, check server is responsive ;; => #t then sucessfully got the lock ;; => #f reserved for future use as to indicate something went wrong (match res ((owner_pid owner_host owner_port event_time) (if (server-ready? uconn (conc owner_host":"owner_port) "abc") #f ;; locked by someone else (begin ;; locked by someone dead and gone (debug:print 0 *default-log-port* "WARNING: stale lock - have to steal it. This may fail.") (db:steal-lock-db dbh dbfile port)))) (#t #t) ;; placeholder so that we don't touch res if it is #t (else (set! res #f))) (sqlite3:finalize! dbh) res)) (define (register-server pkts-dir pkt-spec host port servkey ipaddr dbpath) (let* ((pkt-dat `((host . ,host) (port . ,port) (servkey . ,servkey) (pid . ,(current-process-id)) (ipaddr . ,ipaddr) (dbpath . ,dbpath))) (uuid (write-alist->pkt pkts-dir pkt-dat pktspec: pkt-spec ptype: 'server))) (debug:print 0 *default-log-port* "Server on "host":"port" registered in pkt "uuid) uuid)) (define (get-pkts-dir #!optional (apath #f)) (let* ((effective-toppath (or *toppath* apath))) (assert effective-toppath "ERROR: get-pkts-dir called without *toppath* set. Exiting.") (let* ((pdir (conc effective-toppath "/.meta/srvpkts"))) (if (file-exists? pdir) pdir (begin (handle-exceptions ;; this exception handler should NOT be needed but ... exn pdir (create-directory pdir #t)) pdir))))) ;; given a pkts dir read ;; (define (get-all-server-pkts pktsdir-in pktspec) (let* ((pktsdir (if (file-exists? pktsdir-in) pktsdir-in (begin (create-directory pktsdir-in #t) pktsdir-in))) (all-pkt-files (glob (conc pktsdir "/*.pkt")))) (map (lambda (pkt-file) (read-pkt->alist pkt-file pktspec: pktspec)) all-pkt-files))) (define (server-address srv-pkt) (conc (alist-ref 'host srv-pkt) ":" (alist-ref 'port srv-pkt))) (define (server-ready? uconn host-port key) ;; server-address is host:port (let* ((params `((cmd . ping)(key . ,key))) (data `((cmd . ping) (key . ,key) (params . ,params))) ;; I don't get it. (res (send-receive uconn host-port 'ping data))) (if (eq? res 'ack) ;; yep, likely it is who we want on the other end res #f))) ;; (begin (debug:print-info 0 *default-log-port* "server-ready? => "res) #f)))) ; from the pkts return servers associated with dbpath ;; NOTE: Only one can be alive - have to check on each ;; in the list of pkts returned ;; (define (get-viable-servers serv-pkts dbpath) (let loop ((tail serv-pkts) (res '())) (if (null? tail) res ;; NOTE: sort by age so oldest is considered first (let* ((spkt (car tail))) (loop (cdr tail) (if (equal? dbpath (alist-ref 'dbpath spkt)) (cons spkt res) res)))))) (define (remove-pkts-if-not-alive uconn serv-pkts) (filter (lambda (pkt) (let* ((host (alist-ref 'host pkt)) (port (alist-ref 'port pkt)) (host-port (conc host":"port)) (key (alist-ref 'servkey pkt)) (pktz (alist-ref 'Z pkt)) (res (server-ready? uconn host-port key))) (if res res (let* ((pktsdir (get-pkts-dir *toppath*)) (pktpath (conc pktsdir"/"pktz".pkt"))) (debug:print 0 *default-log-port* "WARNING: pkt with no server "pktpath) (delete-file* pktpath) #f)))) serv-pkts)) ;; from viable servers get one that is alive and ready ;; (define (get-the-server uconn apath serv-pkts) (let loop ((tail serv-pkts)) (if (null? tail) #f (let* ((spkt (car tail)) (host (alist-ref 'ipaddr spkt)) (port (alist-ref 'port spkt)) (host-port (conc host":"port)) (dbpth (alist-ref 'dbpath spkt)) (srvkey (alist-ref 'Z spkt)) ;; (alist-ref 'srvkey spkt)) (addr (server-address spkt))) (if (server-ready? uconn host-port srvkey) spkt (loop (cdr tail))))))) ;; am I the "first" in line server? I.e. my D card is smallest ;; use Z card as tie breaker ;; (define (get-best-candidate serv-pkts dbpath) (if (null? serv-pkts) #f (let loop ((tail serv-pkts) (best (car serv-pkts))) (if (null? tail) best (let* ((candidate (car tail)) (candidate-bd (string->number (alist-ref 'D candidate))) (best-bd (string->number (alist-ref 'D best))) ;; bigger number is younger (candidate-z (alist-ref 'Z candidate)) (best-z (alist-ref 'Z best)) (new-best (cond ((> best-bd candidate-bd) ;; best is younger than candidate candidate) ((< best-bd candidate-bd) ;; candidate is younger than best best) (else (if (string>=? best-z candidate-z) best candidate))))) ;; use Z card as tie breaker (if (null? tail) new-best (loop (cdr tail) new-best))))))) ;;====================================================================== ;; END NEW SERVER METHOD ;;====================================================================== ;; if .db/main.db check the pkts ;; (define (rmt:wait-for-server pkts-dir db-file server-key) (let* ((sdat *db-serv-info*)) (let loop ((start-time (current-seconds)) (changed #t) (last-sdat "not this")) (begin ;; let ((sdat #f)) (thread-sleep! 0.01) (debug:print-info 0 *default-log-port* "Waiting for server alive signature") (mutex-lock! *heartbeat-mutex*) (set! sdat *db-serv-info*) (mutex-unlock! *heartbeat-mutex*) (if (and sdat (not changed) (> (- (current-seconds) start-time) 2)) (let* ((uconn (servdat-uconn sdat))) (servdat-status-set! sdat 'iface-stable) (debug:print-info 0 *default-log-port* "Received server alive signature, now attempting to lock in server") ;; create a server pkt in *toppath*/.meta/srvpkts ;; TODO: ;; 1. change sdat to stuct ;; 2. add uuid to struct ;; 3. update uuid in sdat here ;; (servdat-uuid-set! sdat (register-server pkts-dir *srvpktspec* (get-host-name) (servdat-port sdat) server-key (servdat-host sdat) db-file)) ;; (set! *my-signature* (servdat-uuid sdat)) ;; replace with Z, no, stick with proper key ;; now read pkts and see if we are a contender (let* ((all-pkts (get-all-server-pkts pkts-dir *srvpktspec*)) (viables (get-viable-servers all-pkts db-file)) (alive (remove-pkts-if-not-alive uconn viables)) (best-srv (get-best-candidate alive db-file)) (best-srv-key (if best-srv (alist-ref 'servkey best-srv) #f)) (i-am-srv (equal? best-srv-key server-key)) (delete-pkt (lambda () (let* ((pktfile (conc (get-pkts-dir *toppath*) "/" (servdat-uuid *db-serv-info*) ".pkt"))) (debug:print-info 0 *default-log-port* "Attempting to remove bogus pkt file "pktfile) (delete-file* pktfile))))) ;; remove immediately instead of waiting for on-exit (debug:print 0 *default-log-port* "best-srv-key: "best-srv-key", server-key: "server-key", i-am-srv: "i-am-srv) ;; am I the best-srv, compare server-keys to know (if i-am-srv (if (get-lock-db sdat db-file (servdat-host sdat)(servdat-port sdat)) ;; (db:get-iam-server-lock *dbstruct-db* *toppath* run-id) (begin (debug:print-info 0 *default-log-port* "I'm the server!") (servdat-dbfile-set! sdat db-file) (servdat-status-set! sdat 'db-locked)) (begin (debug:print-info 0 *default-log-port* "I'm not the server, exiting.") (bdat-time-to-exit-set! *bdat* #t) (delete-pkt) (thread-sleep! 0.2) (exit))) (begin (debug:print-info 0 *default-log-port* "Keys do not match "best-srv-key", "server-key", exiting.") (bdat-time-to-exit-set! *bdat* #t) (delete-pkt) (thread-sleep! 0.2) (exit))) sdat)) (begin ;; sdat not yet contains server info (debug:print-info 0 *default-log-port* "Still waiting, last-sdat=" last-sdat) (sleep 4) (if (> (- (current-seconds) start-time) 120) ;; been waiting for two minutes (begin (debug:print-error 0 *default-log-port* "transport appears to have died, exiting server") (exit)) (loop start-time (equal? sdat last-sdat) sdat)))))))) (define (rmt:register-server sinfo apath iface port server-key dbname) (servdat-conns sinfo) ;; just checking types (rmt:open-main-connection sinfo apath) ;; we need a channel to main.db (rmt:send-receive-real sinfo apath ;; params: host port servkey pid ipaddr dbpath (db:run-id->dbname #f) 'register-server `(,iface ,port ,server-key ,(current-process-id) ,iface ,apath ,dbname))) (define (rmt:get-count-servers sinfo apath) (servdat-conns sinfo) ;; just checking types (rmt:open-main-connection sinfo apath) ;; we need a channel to main.db (rmt:send-receive-real sinfo apath ;; params: host port servkey pid ipaddr dbpath (db:run-id->dbname #f) 'get-count-servers `(,apath))) (define (rmt:get-servers-info apath) (rmt:send-receive 'get-servers-info #f `(,apath))) (define (rmt:deregister-server db-serv-info apath iface port server-key dbname) (rmt:open-main-connection db-serv-info apath) ;; we need a channel to main.db (rmt:send-receive-real db-serv-info apath ;; params: host port servkey pid ipaddr dbpath (db:run-id->dbname #f) 'deregister-server `(,iface ,port ,server-key ,(current-process-id) ,iface ,apath ,dbname))) (define (rmt:wait-for-stable-interface #!optional (num-tries-allowed 100)) ;; wait until *db-serv-info* stops changing (let* ((stime (current-seconds))) (let loop ((last-host #f) (last-port #f) (tries 0)) (let* ((curr-host (and *db-serv-info* (servdat-host *db-serv-info*))) (curr-port (and *db-serv-info* (servdat-port *db-serv-info*)))) ;; first we verify port and interface, update *db-serv-info* in need be. (cond ((> tries num-tries-allowed) (debug:print 0 *default-log-port* "rmt:keep-running, giving up after trying for several minutes.") (exit 1)) ((not *db-serv-info*) (thread-sleep! 0.25) (loop curr-host curr-port (+ tries 1))) ((or (not last-host)(not last-port)) (debug:print 0 *default-log-port* "rmt:keep-running, still no interface, tries="tries) (thread-sleep! 0.25) (loop curr-host curr-port (+ tries 1))) ((or (not (equal? last-host curr-host)) (not (equal? last-port curr-port))) (debug:print-info 0 *default-log-port* "WARNING: interface changed, refreshing iface and port info") (thread-sleep! 0.25) (loop curr-host curr-port (+ tries 1))) ((< (- (current-seconds) stime) 1) ;; keep up the looping until at least 3 seconds have passed (thread-sleep! 0.5) (loop curr-host curr-port (+ tries 1))) (else (rmt:get-signature) ;; sets *my-signature* as side effect (servdat-status-set! *db-serv-info* 'interface-stable) (debug:print 0 *default-log-port* "SERVER STARTED: " curr-host ":" curr-port " AT " (current-seconds) " server signature: " *my-signature* " with "(servdat-trynum *db-serv-info*)" port changes") (flush-output *default-log-port*) #t)))))) ;; run rmt:keep-running in a parallel thread to monitor that the db is being ;; used and to shutdown after sometime if it is not. ;; (define (rmt:keep-running dbname) ;; if none running or if > 20 seconds since ;; server last used then start shutdown ;; This thread waits for the server to come alive (debug:print-info 0 *default-log-port* "Starting the sync-back, keep alive thread in server") (let* ((sinfo *db-serv-info*) (server-start-time (current-seconds)) (pkts-dir (get-pkts-dir)) (server-key (rmt:get-signature)) ;; This servers key (is-main (equal? (args:get-arg "-db") ".db/main.db")) (last-access 0) (server-timeout (server:expiration-timeout)) (shutdown-server-sequence (lambda (host port) (set! *unclean-shutdown* #f) ;; Should not be needed anymore (debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id)) ;; (rmt:server-shutdown host port) -- called in on-exit ;; (portlogger:open-run-close portlogger:set-port port "released") called in on-exit (exit))) (timed-out? (lambda () (<= (+ last-access server-timeout) (current-seconds))))) (servdat-dbfile-set! *db-serv-info* (args:get-arg "-db")) ;; main and run db servers have both got wait logic (could/should merge it) (if is-main (rmt:wait-for-server pkts-dir dbname server-key) (rmt:wait-for-stable-interface)) ;; this is our forever loop (let* ((iface (servdat-host *db-serv-info*)) (port (servdat-port *db-serv-info*)) (uconn (servdat-uconn *db-serv-info*))) (let loop ((count 0) (bad-sync-count 0) (start-time (current-milliseconds))) (if (and (not is-main) (common:low-noise-print 60 "servdat-status")) (debug:print-info 0 *default-log-port* "servdat-status is " (servdat-status *db-serv-info*))) (mutex-lock! *heartbeat-mutex*) ;; set up the database handle (if (not *dbstruct-db*) ;; no db opened yet, open the db and register with main if appropriate (let ((watchdog (bdat-watchdog *bdat*))) (debug:print 0 *default-log-port* "SERVER: dbprep") (db:setup dbname) ;; sets *dbstruct-db* as side effect (servdat-status-set! *db-serv-info* 'db-opened) ;; IFF I'm not main, call into main and register self (if (not is-main) (let ((res (rmt:register-server sinfo *toppath* iface port server-key dbname))) (if res ;; we are the server (servdat-status-set! *db-serv-info* 'have-interface-and-db) ;; now check that the db locker is alive, clear it out if not (let* ((serv-info (rmt:server-info *toppath* dbname))) (match serv-info ((host port servkey pid ipaddr apath dbpath) (if (not (server-ready? uconn (conc host":"port) servkey)) (begin (debug:print-info 0 *default-log-port* "Server registered but not alive. Removing and trying again.") (rmt:deregister-server sinfo apath host port servkey dbpath) ;; servkey pid ipaddr apath dbpath) (loop (+ count 1) bad-sync-count start-time)))) (else (debug:print 0 *default-log-port* "We are not the server for "dbname", exiting. Server info is: "serv-info) (exit))))))) (debug:print 0 *default-log-port* "SERVER: running, db "dbname" opened, megatest version: " (common:get-full-version)) ;; start the watchdog ;; is this really needed? #;(if watchdog (if (not (member (thread-state watchdog) '(ready running blocked sleeping dead))) (begin (debug:print-info 0 *default-log-port* "Starting watchdog thread (in state "(thread-state watchdog)")") (thread-start! watchdog)) (debug:print-info 0 *default-log-port* "Not starting watchdog thread (in state "(thread-state watchdog)")")) (debug:print 0 *default-log-port* "ERROR: *watchdog* not setup, cannot start it.")) #;(loop (+ count 1) bad-sync-count start-time) )) (db:sync-inmem->disk *dbstruct-db* *toppath* dbname force-sync: #t) (mutex-unlock! *heartbeat-mutex*) ;; when things go wrong we don't want to be doing the various ;; queries too often so we strive to run this stuff only every ;; four seconds or so. (let* ((sync-time (- (current-milliseconds) start-time)) (rem-time (quotient (- 4000 sync-time) 1000))) (if (and (<= rem-time 4) (> rem-time 0)) (thread-sleep! rem-time))) ;; Transfer *db-last-access* to last-access to use in checking that we are still alive (set! last-access *db-last-access*) (if (< count 1) ;; 3x3 = 9 secs aprox (loop (+ count 1) bad-sync-count (current-milliseconds))) (if (common:low-noise-print 60 "dbstats") (begin (debug:print 0 *default-log-port* "Server stats:") (db:print-current-query-stats))) (let* ((hrs-since-start (/ (- (current-seconds) server-start-time) 3600))) (cond ((not *server-run*) (debug:print-info 0 *default-log-port* "*server-run* set to #f. Shutting down.") (shutdown-server-sequence (get-host-name) port)) ((timed-out?) (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access)) (shutdown-server-sequence (get-host-name) port)) ((and *server-run* (or (not (timed-out?)) (if is-main ;; do not exit if there are other servers (keep main open until all others gone) (> (rmt:get-count-servers sinfo *toppath*) 1) #f))) (if (common:low-noise-print 120 "server continuing") (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access))) (loop 0 bad-sync-count (current-milliseconds))) (else (set! *unclean-shutdown* #f) (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access)) (shutdown-server-sequence (get-host-name) port) #;(debug:print-info 0 *default-log-port* "Sending 'quit to server, received: " (open-send-receive-nn (conc iface":"port) ;; do this here and not in server-shutdown (sexpr->string 'quit)))))))))) (define (rmt:get-reasonable-hostname) (let* ((inhost (or (args:get-arg "-server") "-"))) (if (equal? inhost "-") (get-host-name) inhost))) ;; Call this to start the actual server ;; ;; all routes though here end in exit ... ;; ;; This is the point at which servers are started ;; (define (rmt:server-launch dbname) (debug:print-info 0 *default-log-port* "Entered rmt:server-launch") (let* ((th2 (make-thread (lambda () (debug:print-info 0 *default-log-port* "Server run thread started") (rmt:run (rmt:get-reasonable-hostname))) "Server run")) (th3 (make-thread (lambda () (debug:print-info 0 *default-log-port* "Server monitor thread started") (if (args:get-arg "-server") (rmt:keep-running dbname))) "Keep running"))) (thread-start! th2) (thread-sleep! 0.252) ;; give the server time to settle before starting the keep-running monitor. (thread-start! th3) (set! *didsomething* #t) (thread-join! th2) (thread-join! th3)) #f) ;;====================================================================== ;; S E R V E R - D I R E C T C A L L S ;;====================================================================== (define (rmt:kill-server run-id) (rmt:send-receive 'kill-server #f (list run-id))) (define (rmt:start-server run-id) (rmt:send-receive 'start-server #f (list run-id))) (define (rmt:server-info apath dbname) (rmt:send-receive 'get-server-info #f (list apath dbname))) ;;====================================================================== ;; Nanomsg transport ;;====================================================================== #;(define (is-port-in-use port-num) (let* ((ret #f)) (let-values (((inp oup pid) (process "netstat" (list "-tulpn" )))) (let loop ((inl (read-line inp))) (if (not (eof-object? inl)) (begin (if (string-search (regexp (conc ":" port-num)) inl) (begin ;(print "Output: " inl) (set! ret #t)) (loop (read-line inp))))))) ret)) #;(define (open-nn-connection host-port) (let ((req (make-req-socket)) (uri (conc "tcp://" host-port))) (nng-dial req uri) (socket-set! req 'nng/recvtimeo 2000) req)) #;(define (send-receive-nn req msg) (nng-send req msg) (nng-recv req)) #;(define (close-nn-connection req) (nng-close! req)) ;; ;; open connection to server, send message, close connection ;; ;; ;; (define (open-send-close-nn host-port msg #!key (timeout 3) ) ;; default timeout is 3 seconds ;; (let ((req (make-req-socket 'req)) ;; (uri (conc "tcp://" host-port)) ;; (res #f) ;; ;; (contacts (alist-ref 'contact attrib)) ;; ;; (mode (alist-ref 'mode attrib)) ;; ) ;; (socket-set! req 'nng/recvtimeo 2000) ;; (handle-exceptions ;; exn ;; (let ((emsg ((condition-property-accessor 'exn 'message) exn))) ;; ;; Send notification ;; (debug:print 0 *default-log-port* "ERROR: Failed to connect / send to " uri " message was \"" emsg "\"" ) ;; #f) ;; (nng-dial req uri) ;; ;; (print "Connected to the server " ) ;; (nng-send req msg) ;; ;; (print "Request Sent") ;; (let* ((th1 (make-thread (lambda () ;; (let ((resp (nng-recv req))) ;; (nng-close! req) ;; (set! res (if (equal? resp "ok") ;; #t ;; #f)))) ;; "recv thread")) ;; (th2 (make-thread (lambda () ;; (thread-sleep! timeout) ;; (thread-terminate! th1)) ;; "timer thread"))) ;; (thread-start! th1) ;; (thread-start! th2) ;; (thread-join! th1) ;; res)))) ;; #;(define (open-send-receive-nn host-port msg #!key (timeout 3) ) ;; default timeout is 3 seconds (let ((req (make-req-socket)) (uri (conc "tcp://" host-port)) (res #f)) (handle-exceptions exn (let ((emsg ((condition-property-accessor 'exn 'message) exn))) ;; Send notification (debug:print 0 *default-log-port* "ERROR: Failed to connect / send to " uri " message was \"" emsg "\", exn=" exn) #f) (nng-dial req uri) (nng-send req msg) (let* ((th1 (make-thread (lambda () (let ((resp (nng-recv req))) (nng-close! req) ;; (print resp) (set! res resp))) "recv thread")) (th2 (make-thread (lambda () (thread-sleep! timeout) (thread-terminate! th1)) "timer thread"))) (thread-start! th1) (thread-start! th2) (thread-join! th1) res)))) ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== ;; run ping in separate process, safest way in some cases ;; #;(define (server:ping-server ifaceport) (with-input-from-pipe (conc (common:get-megatest-exe) " -ping " ifaceport) (lambda () (let loop ((inl (read-line)) (res "NOREPLY")) (if (eof-object? inl) (case (string->symbol res) ((NOREPLY) #f) ((LOGIN_OK) #t) (else #f)) (loop (read-line) inl)))))) ;; NOT USED (well, ok, reference in rpc-transport but otherwise not used). ;; #;(define (server:login toppath) (lambda (toppath) (set! *db-last-access* (current-seconds)) ;; might not be needed. (if (equal? *toppath* toppath) #t #f))) ;; (define server:sync-lock-token "SERVER_SYNC_LOCK") ;; (define (server:release-sync-lock) ;; (db:no-sync-del! *no-sync-db* server:sync-lock-token)) ;; (define (server:have-sync-lock?) ;; (let* ((have-lock-pair (db:no-sync-get-lock *no-sync-db* server:sync-lock-token)) ;; (have-lock? (car have-lock-pair)) ;; (lock-time (cdr have-lock-pair)) ;; (lock-age (- (current-seconds) lock-time))) ;; (cond ;; (have-lock? #t) ;; ((>lock-age ;; (* 3 (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 180))) ;; (server:release-sync-lock) ;; (server:have-sync-lock?)) ;; (else #f)))) ) |
Modified ulex/ulex.scm from [42b648b50c] to [c73b8e0289].
1 2 | ;; ulex: Distributed sqlite3 db ;;; | | | 1 2 3 4 5 6 7 8 9 10 | ;; ulex: Distributed sqlite3 db ;;; ;; Copyright (C) 2018-2021 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 |
︙ | ︙ | |||
21 22 23 24 25 26 27 | ;; 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. ;; ;;====================================================================== | | | > | > | > > > | | | > > | > | > | | | > > | | > > | < > > > | | < | | | > > > > > > | < < | < > | > > > > > > > > > | < < > > | | > > | | | < | | | > > > > | | | | < > | | > > | > | > > > > | | | < > > > > > > | > | > | | | < < < < > > | > | < | > > | | < | > > > > | > | | | | | | > > | | > | < < < | | > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > | > > > | > > > > | < > > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < | < | | | > > > > > > > | | < < > | > > > > > > > > | > > > > > | < < < < | > > | > > > > > | > | > > > > > > > | | > > > | < > > > > > > > > > > > > > > > > | | > > > > | < > > | | | > | > > | < | > | < | > | | > | > > > > > > | | < > | > | > | < < < > > > > | | | < > > > > | | < | < | > > | | > | > > > > > > > > > > > > > > > > > > | > < < < < < > > > > > > > > > > > > | < < > > > > > > > > | > | < > | < < < < < | < < | < < < < < > | | | | > > > > > | > | | > > > | < < > | > > > > | > > | | < < < < | | | | | | | | | | | < | > | | | | | < > | | | > > > > > > > > > > | | | | | > | < | | | | < < | > > | > > | | > > | < > | > > > > > | < > > | < < < > | > | | > | | < | | | | < > > | > > > > > > > | | > > | | > | | > > | < | < < < | < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < | < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | 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 | ;; 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. ;; ;;====================================================================== (module ulex * #;( ;; NOTE: looking for the handler proc - find the run-listener :) run-listener ;; (run-listener handler-proc [port]) => uconn ;; NOTE: handler-proc params; ;; (handler-proc rem-host-port qrykey cmd params) send-receive ;; (send-receive uconn host-port cmd data) ;; NOTE: cmd can be any plain text symbol except for these; ;; 'ping 'ack 'goodbye 'response set-work-handler ;; (set-work-handler proc) wait-and-close ;; (wait-and-close uconn) ulex-listener? ;; needed to get the interface:port that was automatically found udat-port udat-host-port ;; for testing only ;; pp-uconn ;; parameters work-method ;; parameter; 'threads, 'mailbox, 'limited, 'direct return-method ;; parameter; 'mailbox, 'polling, 'direct ) (import scheme chicken.base chicken.file chicken.io chicken.time chicken.condition chicken.string chicken.sort chicken.pretty-print address-info mailbox matchable ;; queues regex regex-case simple-exceptions s11n srfi-1 srfi-18 srfi-4 srfi-69 system-information tcp6 typed-records ) ;; udat struct, used by both caller and callee ;; instantiated as uconn by convention ;; (defstruct udat ;; the listener side (port #f) (host-port #f) (socket #f) ;; the peers (peers (make-hash-table)) ;; host:port->peer ;; work handling (work-queue (make-mailbox)) (work-proc #f) ;; set by user (cnum 0) ;; cookie number (mboxes (make-hash-table)) ;; for the replies (avail-cmboxes '()) ;; list of (<cookie> . <mbox>) for re-use ;; threads (numthreads 10) (cmd-thread #f) (work-queue-thread #f) (num-threads-running 0) ) ;; Parameters ;; work-method: (define work-method (make-parameter 'mailbox)) ;; mailbox - all rdat goes through mailbox ;; threads - all rdat immediately executed in new thread ;; direct - no queuing ;; ;; return-method, return the result to waiting send-receive: (define return-method (make-parameter 'mailbox)) ;; mailbox - create a mailbox and use it for passing returning results to send-receive ;; polling - put the result in a hash table keyed by qrykey and send-receive can poll it for result ;; direct - no queuing, result is passed back in single tcp connection ;; ;; ;; struct for keeping track of others we are talking to ;; ;; ;; (defstruct pdat ;; (host-port #f) ;; (conns '()) ;; list of pcon structs, pop one off when calling the peer ;; ) ;; ;; ;; struct for peer connections, keep track of expiration etc. ;; ;; ;; (defstruct pcon ;; (inp #f) ;; (oup #f) ;; (exp (+ (current-seconds) 59)) ;; expires at this time, set to (+ (current-seconds) 59) ;; (lifetime (+ (current-seconds) 600)) ;; throw away and create new after five minutes ;; ) ;;====================================================================== ;; listener ;;====================================================================== ;; is uconn a ulex connector (listener) ;; (define (ulex-listener? uconn) (udat? uconn)) ;; 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 (setup-listener uconn #!optional (port 4242)) (handle-exceptions exn (if (< port 65535) (setup-listener uconn (+ port 1)) #f) (connect-listener uconn port))) (define (connect-listener uconn 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-port-set! uconn port) (udat-host-port-set! uconn (conc addr":"port)) (udat-socket-set! uconn tlsn) uconn)) ;; run-listener does all the work of starting a listener in a thread ;; it then returns control ;; (define (run-listener handler-proc #!optional (port-suggestion 4242)) (let* ((uconn (make-udat))) (udat-work-proc-set! uconn handler-proc) (if (setup-listener uconn port-suggestion) (let* ((th1 (make-thread (lambda ()(ulex-cmd-loop uconn)) "Ulex command loop")) (th2 (make-thread (lambda () (case (work-method) ((mailbox limited) (process-work-queue uconn)))) "Ulex work queue processor"))) ;; (tcp-buffer-size 2048) (thread-start! th1) (thread-start! th2) (udat-cmd-thread-set! uconn th1) (udat-work-queue-thread-set! uconn th2) (print "cmd loop and process workers started, listening on "(udat-host-port uconn)".") uconn) (assert #f "ERROR: run-listener called without proper setup.")))) (define (wait-and-close uconn) (thread-join! (udat-cmd-thread uconn)) (tcp-close (udat-socket uconn))) ;;====================================================================== ;; peers and connections ;;====================================================================== (define *send-mutex* (make-mutex)) ;; 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. ;; ;; NOTE: see below for beginnings of code to allow re-use of tcp connections ;; - I believe (without substantial evidence) that re-using connections will ;; be beneficial ... ;; (define (send udata host-port qrykey cmd params) (let* ((my-host-port (udat-host-port udata)) ;; remote will return to this (isme #f #;(equal? host-port my-host-port)) ;; calling myself? ;; dat is a self-contained work block that can be sent or handled locally (dat (list my-host-port qrykey cmd params #;(cons (current-seconds)(current-milliseconds))))) (cond (isme (ulex-handler udata dat)) ;; no transmission needed (else (handle-exceptions ;; TODO - MAKE THIS EXCEPTION CMD SPECIFIC? exn (message exn) (begin ;; (mutex-lock! *send-mutex*) ;; DOESN'T SEEM TO HELP (let-values (((inp oup)(tcp-connect host-port))) (let ((res (if (and inp oup) (begin (serialize dat oup) (close-output-port oup) (deserialize inp) ) (begin (print "ERROR: send called but no receiver has been setup. Please call setup first!") #f)))) (close-input-port inp) ;; (mutex-unlock! *send-mutex*) ;; DOESN'T SEEM TO HELP res)))))))) ;; res will always be 'ack unless return-method is direct (define (send-via-polling uconn host-port cmd data) (let* ((qrykey (make-cookie uconn)) (sres (send uconn host-port qrykey cmd data))) (case sres ((ack) (let loop ((start-time (current-milliseconds))) (if (> (current-milliseconds)(+ start-time 10000)) ;; ten seconds timeout (begin (print "ULEX ERROR: timed out waiting for response from "host-port", "cmd" "data) #f) (let* ((result (hash-table-ref/default (udat-mboxes uconn) qrykey #f))) ;; NOTE: we are re-using mboxes hash (if result ;; result is '(status . result-data) or #f for nothing yet (begin (hash-table-delete! (udat-mboxes uconn) qrykey) (cdr result)) (begin (thread-sleep! 0.01) (loop start-time))))))) (else (print "ULEX ERROR: Communication failed? sres="sres) #f)))) (define (send-via-mailbox uconn host-port cmd data) (let* ((cmbox (get-cmbox uconn)) ;; would it be better to keep a stack of mboxes to reuse? (qrykey (car cmbox)) (mbox (cdr cmbox)) (mbox-time (current-milliseconds)) (sres (send uconn host-port qrykey cmd data))) ;; short res (if (eq? sres 'ack) ;; BUG: change to be less than server:expiration-timeout? (let* ((mbox-timeout-secs 120 #;(if (eq? 'primordial (thread-name (current-thread))) #f 120)) ;; timeout) (mbox-timeout-result 'MBOX_TIMEOUT) (res (mailbox-receive! mbox mbox-timeout-secs mbox-timeout-result)) (mbox-receive-time (current-milliseconds))) ;; (put-cmbox uconn cmbox) ;; reuse mbox and cookie. is it worth it? (hash-table-delete! (udat-mboxes uconn) qrykey) (if (eq? res 'MBOX_TIMEOUT) (begin (print "WARNING: mbox timed out for query "cmd", with data "data ", waiting for response from "host-port".") ;; here it might make sense to clean up connection records and force clean start? ;; NO. The progam using ulex needs to do the reset. Right thing here is exception #f) ;; convert to raising exception? res)) (begin (print "ERROR: Communication failed? Got "sres) #f)))) ;; 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 uconn host-port cmd data) (let* ((start-time (current-milliseconds)) (result (cond ((member cmd '(ping goodbye)) ;; these are immediate (send uconn host-port 'ping cmd data)) ((eq? (work-method) 'direct) ;; the result from send will be the actual result, not an 'ack (send uconn host-port 'direct cmd data)) (else (case (return-method) ((polling) (send-via-polling uconn host-port cmd data)) ((mailbox) (send-via-mailbox uconn host-port cmd data)) (else (print "ULEX ERROR: unrecognised return-method "(return-method)".") #f))))) (duration (- (current-milliseconds) start-time))) ;; this is ONLY for development and debugging. It will be removed once Ulex is stable. (if (< 5000 duration) (print "ULEX WARNING: round-trip took "(inexact->exact (round (/ duration 1000))) " seconds; "cmd", host-port="host-port", data="data)) result)) ;;====================================================================== ;; responder side ;;====================================================================== ;; take a request, rdat, and if not immediate put it in the work queue ;; ;; Reserved cmds; ack ping goodbye response ;; (define (ulex-handler uconn rdat) (assert (list? rdat) "FATAL: ulex-handler give rdat as not list") (match rdat ;; (string-split controldat) ((rem-host-port qrykey cmd params);; timedata) ;; (print "ulex-handler got: "rem-host-port" qrykey: "qrykey" cmd: "cmd" params: "params) (case cmd ;; ((ack )(print "Got ack! But why? Should NOT get here.") 'ack) ((ping) ;; (print "Got Ping!") ;; (add-to-work-queue uconn rdat) 'ack) ((goodbye) ;; just clear out references to the caller. NOT COMPLETE (add-to-work-queue uconn rdat) 'ack) ((response) ;; this is a result from remote processing, send it as mail ... (case (return-method) ((polling) (hash-table-set! (udat-mboxes uconn) qrykey (cons 'ok params)) 'ack) ((mailbox) (let ((mbox (hash-table-ref/default (udat-mboxes uconn) qrykey #f))) (if mbox (begin (mailbox-send! mbox params) ;; params here is our result 'ack) (begin (print "ERROR: received result but no associated mbox for cookie "qrykey) 'no-mbox-found)))) (else (print "ULEX ERROR: unrecognised return-method "(return-method)) 'bad-return-method))) (else ;; generic request - hand it to the work queue (add-to-work-queue uconn rdat) 'ack))) (else (print "ULEX ERROR: bad rdat "rdat) 'bad-rdat))) ;; given an already set up uconn start the cmd-loop ;; (define (ulex-cmd-loop uconn) (let* ((serv-listener (udat-socket uconn)) (listener (lambda () (let loop ((state 'start)) (let-values (((inp oup)(tcp-accept serv-listener))) ;; (mutex-lock! *send-mutex*) ;; DOESN'T SEEM TO HELP (let* ((rdat (deserialize inp)) ;; '(my-host-port qrykey cmd params) (resp (ulex-handler uconn rdat))) (serialize resp oup) (close-input-port inp) (close-output-port oup) ;; (mutex-unlock! *send-mutex*) ;; DOESN'T SEEM TO HELP ) (loop state)))))) ;; start N of them (let loop ((thnum 0) (threads '())) (if (< thnum 100) (let* ((th (make-thread listener (conc "listener" thnum)))) (thread-start! th) (loop (+ thnum 1) (cons th threads))) (map thread-join! threads))))) ;; add a proc to the cmd list, these are done symetrically (i.e. in all instances) ;; so that the proc can be dereferenced remotely ;; (define (set-work-handler uconn proc) (udat-work-proc-set! uconn proc)) ;;====================================================================== ;; work queues - this is all happening on the listener side ;;====================================================================== ;; rdat is (rem-host-port qrykey cmd params) (define (add-to-work-queue uconn rdat) #;(queue-add! (udat-work-queue uconn) rdat) (case (work-method) ((threads) (thread-start! (make-thread (lambda () (do-work uconn rdat)) "worker thread"))) ((mailbox) (mailbox-send! (udat-work-queue uconn) rdat)) ((direct) (do-work uconn rdat)) (else (print "ULEX ERROR: work-method "(work-method)" not recognised, using mailbox.") (mailbox-send! (udat-work-queue uconn) rdat)))) ;; move the logic to return the result somewhere else? ;; (define (do-work uconn rdat) (let* ((proc (udat-work-proc uconn))) ;; get it each time - conceivebly it could change ;; put this following into a do-work procedure (match rdat ((rem-host-port qrykey cmd params) (let* ((start-time (current-milliseconds)) (result (proc rem-host-port qrykey cmd params)) (end-time (current-milliseconds)) (run-time (- end-time start-time))) (case (work-method) ((direct) result) (else (if (> run-time 1000)(print "ULEX: Warning, work "cmd", "params" done in "run-time" ms")) ;; send 'response as cmd and result as params (send uconn rem-host-port qrykey 'response result) ;; could check for ack (let* ((duration (- (current-milliseconds) end-time))) (if (> duration 500)(print "ULEX: Warning, response sent back to "rem-host-port" for "qrykey" in "duration"ms"))))))) (MBOX_TIMEOUT 'do-work-timeout) (else (print "ERROR: rdat "rdat", did not match rem-host-port qrykey cmd params"))))) ;; NEW APPROACH: ;; (define (process-work-queue uconn) (let ((wqueue (udat-work-queue uconn)) (proc (udat-work-proc uconn)) (numthr (udat-numthreads uconn))) (let loop ((thnum 1) (threads '())) (let ((thlst (cons (make-thread (lambda () (let work-loop () (let ((rdat (mailbox-receive! wqueue 24000 'MBOX_TIMEOUT))) (do-work uconn rdat)) (work-loop))) (conc "work thread " thnum)) threads))) (if (< thnum numthr) (loop (+ thnum 1) thlst) (begin (print "ULEX: Starting "(length thlst)" worker threads.") (map thread-start! thlst) (print "ULEX: Threads started. Joining all.") (map thread-join! thlst))))))) ;; below was to enable re-use of connections. This seems non-trivial so for ;; now lets open on each call ;; ;; ;; given host-port get or create peer struct ;; ;; ;; (define (udat-get-peer uconn host-port) ;; (or (hash-table-ref/default (udat-peers uconn) host-port #f) ;; ;; no peer, so create pdat and init it ;; ;; ;; NEED stack of connections, pop and use; inp, oup, ;; ;; creation_time (remove and create new if over 24hrs old ;; ;; ;; (let ((pdat (make-pdat host-port: host-port))) ;; (hash-table-set! (udat-peers uconn) host-port pdat) ;; pdat))) ;; ;; ;; is pcon alive ;; ;; ;; given host-port and pdat get a pcon ;; ;; ;; (define (pdat-get-pcon pdat host-port) ;; (let loop ((conns (pdat-conns pdat))) ;; (if (null? conns) ;; none? make and return - do NOT add - it will be pushed back on list later ;; (init-pcon (make-pcon)) ;; (let* ((conn (pop conns))) ;; ;; ;; given host-port get a pcon struct ;; ;; ;; (define (udat-get-pcon ;;====================================================================== ;; misc utils ;;====================================================================== (define (make-cookie uconn) (let ((newcnum (+ (udat-cnum uconn) 1))) (udat-cnum-set! uconn newcnum) (conc (udat-host-port uconn) ":" newcnum))) ;; cookie/mboxes ;; we store each mbox with a cookie (<cookie> . <mbox>) ;; (define (get-cmbox uconn) (if (null? (udat-avail-cmboxes uconn)) (let ((cookie (make-cookie uconn)) (mbox (make-mailbox))) (hash-table-set! (udat-mboxes uconn) cookie mbox) `(,cookie . ,mbox)) (let ((cmbox (car (udat-avail-cmboxes uconn)))) (udat-avail-cmboxes-set! uconn (cdr (udat-avail-cmboxes uconn))) cmbox))) (define (put-cmbox uconn cmbox) (udat-avail-cmboxes-set! uconn (cons cmbox (udat-avail-cmboxes uconn)))) (define (pp-uconn uconn) (pp (udat->alist uconn))) ;;====================================================================== ;; network utilities ;;====================================================================== ;; NOTE: Look at address-info egg as alternative to some of this (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))) (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?)))))) (define (get-all-ips-sorted) (sort (get-all-ips) ip-pref-less?)) (define (get-all-ips) (map address-info-host (filter (lambda (x) (equal? (address-info-type x) "tcp")) (address-infos (get-host-name))))) ) |
Added utils/convert-db.sh version [8205e222a7].
> > > > > > > > > > > > > > > > > > > > > > > > > | 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 | #!/bin/bash if [ -z "megatest.config" ]; then echo "The file 'megatest.config' does not exist. This must be run in a megatest area." exit 1 fi if [ -d ".mtdb" ]; then echo "The .mtdb directory already exists. Will not do the conversion" exit 1 fi if [ -d ".megatest" ]; then echo "Found a .megatest directory. Will convert from megatest 1.70 to 1.71/1.80 format" /p/foundry/env/pkgs/megatest/1.70/16/bin/megatest -list-runs % -dumpmode sexpr > data.sexpr else if [ -f "megatest.db" ]; then echo "Found megatest.db. Will convert from megatest 1.65 to 1.71/1.80 format" /p/foundry/env/pkgs/megatest/1.65/92/bin/megatest -list-runs % -dumpmode sexpr > data.sexpr else echo "Did not find .megatest or megatest.db. Cannot do the conversion" exit 1 fi fi which megatest megatest -import-sexpr data.sexpr |
Added utils/java-script-lib version [07e11f049f].
> > > > | 1 2 3 4 | /*! jQuery v3.1.0 -ajax,-ajax/jsonp,-ajax/load,-ajax/parseXML,-ajax/script,-ajax/var/location,-ajax/var/nonce,-ajax/var/rquery,-ajax/xhr,-manipulation/_evalUrl,-event/ajax,-effects,-effects/Tween,-effects/animatedSelector,-deprecated | (c) jQuery Foundation | jquery.org/license */ !function(a,b){"use strict";"object"==typeof module&&"object"==typeof module.exports?module.exports=a.document?b(a,!0):function(a){if(!a.document)throw new Error("jQuery requires a window with a document");return b(a)}:b(a)}("undefined"!=typeof window?window:this,function(a,b){"use strict";var c=[],d=a.document,e=Object.getPrototypeOf,f=c.slice,g=c.concat,h=c.push,i=c.indexOf,j={},k=j.toString,l=j.hasOwnProperty,m=l.toString,n=m.call(Object),o={};function p(a,b){b=b||d;var c=b.createElement("script");c.text=a,b.head.appendChild(c).parentNode.removeChild(c)}var q="3.1.0 -ajax,-ajax/jsonp,-ajax/load,-ajax/parseXML,-ajax/script,-ajax/var/location,-ajax/var/nonce,-ajax/var/rquery,-ajax/xhr,-manipulation/_evalUrl,-event/ajax,-effects,-effects/Tween,-effects/animatedSelector,-deprecated",r=function(a,b){return new r.fn.init(a,b)},s=/^[\s\uFEFF\xA0]+|[\s\uFEFF\xA0]+$/g,t=/^-ms-/,u=/-([a-z])/g,v=function(a,b){return b.toUpperCase()};r.fn=r.prototype={jquery:q,constructor:r,length:0,toArray:function(){return f.call(this)},get:function(a){return null!=a?a<0?this[a+this.length]:this[a]:f.call(this)},pushStack:function(a){var b=r.merge(this.constructor(),a);return b.prevObject=this,b},each:function(a){return r.each(this,a)},map:function(a){return this.pushStack(r.map(this,function(b,c){return a.call(b,c,b)}))},slice:function(){return this.pushStack(f.apply(this,arguments))},first:function(){return this.eq(0)},last:function(){return this.eq(-1)},eq:function(a){var b=this.length,c=+a+(a<0?b:0);return this.pushStack(c>=0&&c<b?[this[c]]:[])},end:function(){return this.prevObject||this.constructor()},push:h,sort:c.sort,splice:c.splice},r.extend=r.fn.extend=function(){var a,b,c,d,e,f,g=arguments[0]||{},h=1,i=arguments.length,j=!1;for("boolean"==typeof g&&(j=g,g=arguments[h]||{},h++),"object"==typeof g||r.isFunction(g)||(g={}),h===i&&(g=this,h--);h<i;h++)if(null!=(a=arguments[h]))for(b in a)c=g[b],d=a[b],g!==d&&(j&&d&&(r.isPlainObject(d)||(e=r.isArray(d)))?(e?(e=!1,f=c&&r.isArray(c)?c:[]):f=c&&r.isPlainObject(c)?c:{},g[b]=r.extend(j,f,d)):void 0!==d&&(g[b]=d));return g},r.extend({expando:"jQuery"+(q+Math.random()).replace(/\D/g,""),isReady:!0,error:function(a){throw new Error(a)},noop:function(){},isFunction:function(a){return"function"===r.type(a)},isArray:Array.isArray,isWindow:function(a){return null!=a&&a===a.window},isNumeric:function(a){var b=r.type(a);return("number"===b||"string"===b)&&!isNaN(a-parseFloat(a))},isPlainObject:function(a){var b,c;return!(!a||"[object Object]"!==k.call(a))&&(!(b=e(a))||(c=l.call(b,"constructor")&&b.constructor,"function"==typeof c&&m.call(c)===n))},isEmptyObject:function(a){var b;for(b in a)return!1;return!0},type:function(a){return null==a?a+"":"object"==typeof a||"function"==typeof a?j[k.call(a)]||"object":typeof a},globalEval:function(a){p(a)},camelCase:function(a){return a.replace(t,"ms-").replace(u,v)},nodeName:function(a,b){return a.nodeName&&a.nodeName.toLowerCase()===b.toLowerCase()},each:function(a,b){var c,d=0;if(w(a)){for(c=a.length;d<c;d++)if(b.call(a[d],d,a[d])===!1)break}else for(d in a)if(b.call(a[d],d,a[d])===!1)break;return a},trim:function(a){return null==a?"":(a+"").replace(s,"")},makeArray:function(a,b){var c=b||[];return null!=a&&(w(Object(a))?r.merge(c,"string"==typeof a?[a]:a):h.call(c,a)),c},inArray:function(a,b,c){return null==b?-1:i.call(b,a,c)},merge:function(a,b){for(var c=+b.length,d=0,e=a.length;d<c;d++)a[e++]=b[d];return a.length=e,a},grep:function(a,b,c){for(var d,e=[],f=0,g=a.length,h=!c;f<g;f++)d=!b(a[f],f),d!==h&&e.push(a[f]);return e},map:function(a,b,c){var d,e,f=0,h=[];if(w(a))for(d=a.length;f<d;f++)e=b(a[f],f,c),null!=e&&h.push(e);else for(f in a)e=b(a[f],f,c),null!=e&&h.push(e);return g.apply([],h)},guid:1,proxy:function(a,b){var c,d,e;if("string"==typeof b&&(c=a[b],b=a,a=c),r.isFunction(a))return d=f.call(arguments,2),e=function(){return a.apply(b||this,d.concat(f.call(arguments)))},e.guid=a.guid=a.guid||r.guid++,e},now:Date.now,support:o}),"function"==typeof Symbol&&(r.fn[Symbol.iterator]=c[Symbol.iterator]),r.each("Boolean Number String Function Array Date RegExp Object Error Symbol".split(" "),function(a,b){j["[object "+b+"]"]=b.toLowerCase()});function w(a){var b=!!a&&"length"in a&&a.length,c=r.type(a);return"function"!==c&&!r.isWindow(a)&&("array"===c||0===b||"number"==typeof b&&b>0&&b-1 in a)}var x=function(a){var b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u="sizzle"+1*new Date,v=a.document,w=0,x=0,y=ha(),z=ha(),A=ha(),B=function(a,b){return a===b&&(l=!0),0},C={}.hasOwnProperty,D=[],E=D.pop,F=D.push,G=D.push,H=D.slice,I=function(a,b){for(var c=0,d=a.length;c<d;c++)if(a[c]===b)return c;return-1},J="checked|selected|async|autofocus|autoplay|controls|defer|disabled|hidden|ismap|loop|multiple|open|readonly|required|scoped",K="[\\x20\\t\\r\\n\\f]",L="(?:\\\\.|[\\w-]|[^\0-\\xa0])+",M="\\["+K+"*("+L+")(?:"+K+"*([*^$|!~]?=)"+K+"*(?:'((?:\\\\.|[^\\\\'])*)'|\"((?:\\\\.|[^\\\\\"])*)\"|("+L+"))|)"+K+"*\\]",N=":("+L+")(?:\\((('((?:\\\\.|[^\\\\'])*)'|\"((?:\\\\.|[^\\\\\"])*)\")|((?:\\\\.|[^\\\\()[\\]]|"+M+")*)|.*)\\)|)",O=new RegExp(K+"+","g"),P=new RegExp("^"+K+"+|((?:^|[^\\\\])(?:\\\\.)*)"+K+"+$","g"),Q=new RegExp("^"+K+"*,"+K+"*"),R=new RegExp("^"+K+"*([>+~]|"+K+")"+K+"*"),S=new RegExp("="+K+"*([^\\]'\"]*?)"+K+"*\\]","g"),T=new RegExp(N),U=new RegExp("^"+L+"$"),V={ID:new RegExp("^#("+L+")"),CLASS:new RegExp("^\\.("+L+")"),TAG:new RegExp("^("+L+"|[*])"),ATTR:new RegExp("^"+M),PSEUDO:new RegExp("^"+N),CHILD:new RegExp("^:(only|first|last|nth|nth-last)-(child|of-type)(?:\\("+K+"*(even|odd|(([+-]|)(\\d*)n|)"+K+"*(?:([+-]|)"+K+"*(\\d+)|))"+K+"*\\)|)","i"),bool:new RegExp("^(?:"+J+")$","i"),needsContext:new RegExp("^"+K+"*[>+~]|:(even|odd|eq|gt|lt|nth|first|last)(?:\\("+K+"*((?:-\\d)?\\d*)"+K+"*\\)|)(?=[^-]|$)","i")},W=/^(?:input|select|textarea|button)$/i,X=/^h\d$/i,Y=/^[^{]+\{\s*\[native \w/,Z=/^(?:#([\w-]+)|(\w+)|\.([\w-]+))$/,$=/[+~]/,_=new RegExp("\\\\([\\da-f]{1,6}"+K+"?|("+K+")|.)","ig"),aa=function(a,b,c){var d="0x"+b-65536;return d!==d||c?b:d<0?String.fromCharCode(d+65536):String.fromCharCode(d>>10|55296,1023&d|56320)},ba=/([\0-\x1f\x7f]|^-?\d)|^-$|[^\x80-\uFFFF\w-]/g,ca=function(a,b){return b?"\0"===a?"\ufffd":a.slice(0,-1)+"\\"+a.charCodeAt(a.length-1).toString(16)+" ":"\\"+a},da=function(){m()},ea=ta(function(a){return a.disabled===!0},{dir:"parentNode",next:"legend"});try{G.apply(D=H.call(v.childNodes),v.childNodes),D[v.childNodes.length].nodeType}catch(fa){G={apply:D.length?function(a,b){F.apply(a,H.call(b))}:function(a,b){var c=a.length,d=0;while(a[c++]=b[d++]);a.length=c-1}}}function ga(a,b,d,e){var f,h,j,k,l,o,r,s=b&&b.ownerDocument,w=b?b.nodeType:9;if(d=d||[],"string"!=typeof a||!a||1!==w&&9!==w&&11!==w)return d;if(!e&&((b?b.ownerDocument||b:v)!==n&&m(b),b=b||n,p)){if(11!==w&&(l=Z.exec(a)))if(f=l[1]){if(9===w){if(!(j=b.getElementById(f)))return d;if(j.id===f)return d.push(j),d}else if(s&&(j=s.getElementById(f))&&t(b,j)&&j.id===f)return d.push(j),d}else{if(l[2])return G.apply(d,b.getElementsByTagName(a)),d;if((f=l[3])&&c.getElementsByClassName&&b.getElementsByClassName)return G.apply(d,b.getElementsByClassName(f)),d}if(c.qsa&&!A[a+" "]&&(!q||!q.test(a))){if(1!==w)s=b,r=a;else if("object"!==b.nodeName.toLowerCase()){(k=b.getAttribute("id"))?k=k.replace(ba,ca):b.setAttribute("id",k=u),o=g(a),h=o.length;while(h--)o[h]="#"+k+" "+sa(o[h]);r=o.join(","),s=$.test(a)&&qa(b.parentNode)||b}if(r)try{return G.apply(d,s.querySelectorAll(r)),d}catch(x){}finally{k===u&&b.removeAttribute("id")}}}return i(a.replace(P,"$1"),b,d,e)}function ha(){var a=[];function b(c,e){return a.push(c+" ")>d.cacheLength&&delete b[a.shift()],b[c+" "]=e}return b}function ia(a){return a[u]=!0,a}function ja(a){var b=n.createElement("fieldset");try{return!!a(b)}catch(c){return!1}finally{b.parentNode&&b.parentNode.removeChild(b),b=null}}function ka(a,b){var c=a.split("|"),e=c.length;while(e--)d.attrHandle[c[e]]=b}function la(a,b){var c=b&&a,d=c&&1===a.nodeType&&1===b.nodeType&&a.sourceIndex-b.sourceIndex;if(d)return d;if(c)while(c=c.nextSibling)if(c===b)return-1;return a?1:-1}function ma(a){return function(b){var c=b.nodeName.toLowerCase();return"input"===c&&b.type===a}}function na(a){return function(b){var c=b.nodeName.toLowerCase();return("input"===c||"button"===c)&&b.type===a}}function oa(a){return function(b){return"label"in b&&b.disabled===a||"form"in b&&b.disabled===a||"form"in b&&b.disabled===!1&&(b.isDisabled===a||b.isDisabled!==!a&&("label"in b||!ea(b))!==a)}}function pa(a){return ia(function(b){return b=+b,ia(function(c,d){var e,f=a([],c.length,b),g=f.length;while(g--)c[e=f[g]]&&(c[e]=!(d[e]=c[e]))})})}function qa(a){return a&&"undefined"!=typeof a.getElementsByTagName&&a}c=ga.support={},f=ga.isXML=function(a){var b=a&&(a.ownerDocument||a).documentElement;return!!b&&"HTML"!==b.nodeName},m=ga.setDocument=function(a){var b,e,g=a?a.ownerDocument||a:v;return g!==n&&9===g.nodeType&&g.documentElement?(n=g,o=n.documentElement,p=!f(n),v!==n&&(e=n.defaultView)&&e.top!==e&&(e.addEventListener?e.addEventListener("unload",da,!1):e.attachEvent&&e.attachEvent("onunload",da)),c.attributes=ja(function(a){return a.className="i",!a.getAttribute("className")}),c.getElementsByTagName=ja(function(a){return a.appendChild(n.createComment("")),!a.getElementsByTagName("*").length}),c.getElementsByClassName=Y.test(n.getElementsByClassName),c.getById=ja(function(a){return o.appendChild(a).id=u,!n.getElementsByName||!n.getElementsByName(u).length}),c.getById?(d.find.ID=function(a,b){if("undefined"!=typeof b.getElementById&&p){var c=b.getElementById(a);return c?[c]:[]}},d.filter.ID=function(a){var b=a.replace(_,aa);return function(a){return a.getAttribute("id")===b}}):(delete d.find.ID,d.filter.ID=function(a){var b=a.replace(_,aa);return function(a){var c="undefined"!=typeof a.getAttributeNode&&a.getAttributeNode("id");return c&&c.value===b}}),d.find.TAG=c.getElementsByTagName?function(a,b){return"undefined"!=typeof b.getElementsByTagName?b.getElementsByTagName(a):c.qsa?b.querySelectorAll(a):void 0}:function(a,b){var c,d=[],e=0,f=b.getElementsByTagName(a);if("*"===a){while(c=f[e++])1===c.nodeType&&d.push(c);return d}return f},d.find.CLASS=c.getElementsByClassName&&function(a,b){if("undefined"!=typeof b.getElementsByClassName&&p)return b.getElementsByClassName(a)},r=[],q=[],(c.qsa=Y.test(n.querySelectorAll))&&(ja(function(a){o.appendChild(a).innerHTML="<a id='"+u+"'></a><select id='"+u+"-\r\\' msallowcapture=''><option selected=''></option></select>",a.querySelectorAll("[msallowcapture^='']").length&&q.push("[*^$]="+K+"*(?:''|\"\")"),a.querySelectorAll("[selected]").length||q.push("\\["+K+"*(?:value|"+J+")"),a.querySelectorAll("[id~="+u+"-]").length||q.push("~="),a.querySelectorAll(":checked").length||q.push(":checked"),a.querySelectorAll("a#"+u+"+*").length||q.push(".#.+[+~]")}),ja(function(a){a.innerHTML="<a href='' disabled='disabled'></a><select disabled='disabled'><option/></select>";var b=n.createElement("input");b.setAttribute("type","hidden"),a.appendChild(b).setAttribute("name","D"),a.querySelectorAll("[name=d]").length&&q.push("name"+K+"*[*^$|!~]?="),2!==a.querySelectorAll(":enabled").length&&q.push(":enabled",":disabled"),o.appendChild(a).disabled=!0,2!==a.querySelectorAll(":disabled").length&&q.push(":enabled",":disabled"),a.querySelectorAll("*,:x"),q.push(",.*:")})),(c.matchesSelector=Y.test(s=o.matches||o.webkitMatchesSelector||o.mozMatchesSelector||o.oMatchesSelector||o.msMatchesSelector))&&ja(function(a){c.disconnectedMatch=s.call(a,"*"),s.call(a,"[s!='']:x"),r.push("!=",N)}),q=q.length&&new RegExp(q.join("|")),r=r.length&&new RegExp(r.join("|")),b=Y.test(o.compareDocumentPosition),t=b||Y.test(o.contains)?function(a,b){var c=9===a.nodeType?a.documentElement:a,d=b&&b.parentNode;return a===d||!(!d||1!==d.nodeType||!(c.contains?c.contains(d):a.compareDocumentPosition&&16&a.compareDocumentPosition(d)))}:function(a,b){if(b)while(b=b.parentNode)if(b===a)return!0;return!1},B=b?function(a,b){if(a===b)return l=!0,0;var d=!a.compareDocumentPosition-!b.compareDocumentPosition;return d?d:(d=(a.ownerDocument||a)===(b.ownerDocument||b)?a.compareDocumentPosition(b):1,1&d||!c.sortDetached&&b.compareDocumentPosition(a)===d?a===n||a.ownerDocument===v&&t(v,a)?-1:b===n||b.ownerDocument===v&&t(v,b)?1:k?I(k,a)-I(k,b):0:4&d?-1:1)}:function(a,b){if(a===b)return l=!0,0;var c,d=0,e=a.parentNode,f=b.parentNode,g=[a],h=[b];if(!e||!f)return a===n?-1:b===n?1:e?-1:f?1:k?I(k,a)-I(k,b):0;if(e===f)return la(a,b);c=a;while(c=c.parentNode)g.unshift(c);c=b;while(c=c.parentNode)h.unshift(c);while(g[d]===h[d])d++;return d?la(g[d],h[d]):g[d]===v?-1:h[d]===v?1:0},n):n},ga.matches=function(a,b){return ga(a,null,null,b)},ga.matchesSelector=function(a,b){if((a.ownerDocument||a)!==n&&m(a),b=b.replace(S,"='$1']"),c.matchesSelector&&p&&!A[b+" "]&&(!r||!r.test(b))&&(!q||!q.test(b)))try{var d=s.call(a,b);if(d||c.disconnectedMatch||a.document&&11!==a.document.nodeType)return d}catch(e){}return ga(b,n,null,[a]).length>0},ga.contains=function(a,b){return(a.ownerDocument||a)!==n&&m(a),t(a,b)},ga.attr=function(a,b){(a.ownerDocument||a)!==n&&m(a);var e=d.attrHandle[b.toLowerCase()],f=e&&C.call(d.attrHandle,b.toLowerCase())?e(a,b,!p):void 0;return void 0!==f?f:c.attributes||!p?a.getAttribute(b):(f=a.getAttributeNode(b))&&f.specified?f.value:null},ga.escape=function(a){return(a+"").replace(ba,ca)},ga.error=function(a){throw new Error("Syntax error, unrecognized expression: "+a)},ga.uniqueSort=function(a){var b,d=[],e=0,f=0;if(l=!c.detectDuplicates,k=!c.sortStable&&a.slice(0),a.sort(B),l){while(b=a[f++])b===a[f]&&(e=d.push(f));while(e--)a.splice(d[e],1)}return k=null,a},e=ga.getText=function(a){var b,c="",d=0,f=a.nodeType;if(f){if(1===f||9===f||11===f){if("string"==typeof a.textContent)return a.textContent;for(a=a.firstChild;a;a=a.nextSibling)c+=e(a)}else if(3===f||4===f)return a.nodeValue}else while(b=a[d++])c+=e(b);return c},d=ga.selectors={cacheLength:50,createPseudo:ia,match:V,attrHandle:{},find:{},relative:{">":{dir:"parentNode",first:!0}," ":{dir:"parentNode"},"+":{dir:"previousSibling",first:!0},"~":{dir:"previousSibling"}},preFilter:{ATTR:function(a){return a[1]=a[1].replace(_,aa),a[3]=(a[3]||a[4]||a[5]||"").replace(_,aa),"~="===a[2]&&(a[3]=" "+a[3]+" "),a.slice(0,4)},CHILD:function(a){return a[1]=a[1].toLowerCase(),"nth"===a[1].slice(0,3)?(a[3]||ga.error(a[0]),a[4]=+(a[4]?a[5]+(a[6]||1):2*("even"===a[3]||"odd"===a[3])),a[5]=+(a[7]+a[8]||"odd"===a[3])):a[3]&&ga.error(a[0]),a},PSEUDO:function(a){var b,c=!a[6]&&a[2];return V.CHILD.test(a[0])?null:(a[3]?a[2]=a[4]||a[5]||"":c&&T.test(c)&&(b=g(c,!0))&&(b=c.indexOf(")",c.length-b)-c.length)&&(a[0]=a[0].slice(0,b),a[2]=c.slice(0,b)),a.slice(0,3))}},filter:{TAG:function(a){var b=a.replace(_,aa).toLowerCase();return"*"===a?function(){return!0}:function(a){return a.nodeName&&a.nodeName.toLowerCase()===b}},CLASS:function(a){var b=y[a+" "];return b||(b=new RegExp("(^|"+K+")"+a+"("+K+"|$)"))&&y(a,function(a){return b.test("string"==typeof a.className&&a.className||"undefined"!=typeof a.getAttribute&&a.getAttribute("class")||"")})},ATTR:function(a,b,c){return function(d){var e=ga.attr(d,a);return null==e?"!="===b:!b||(e+="","="===b?e===c:"!="===b?e!==c:"^="===b?c&&0===e.indexOf(c):"*="===b?c&&e.indexOf(c)>-1:"$="===b?c&&e.slice(-c.length)===c:"~="===b?(" "+e.replace(O," ")+" ").indexOf(c)>-1:"|="===b&&(e===c||e.slice(0,c.length+1)===c+"-"))}},CHILD:function(a,b,c,d,e){var f="nth"!==a.slice(0,3),g="last"!==a.slice(-4),h="of-type"===b;return 1===d&&0===e?function(a){return!!a.parentNode}:function(b,c,i){var j,k,l,m,n,o,p=f!==g?"nextSibling":"previousSibling",q=b.parentNode,r=h&&b.nodeName.toLowerCase(),s=!i&&!h,t=!1;if(q){if(f){while(p){m=b;while(m=m[p])if(h?m.nodeName.toLowerCase()===r:1===m.nodeType)return!1;o=p="only"===a&&!o&&"nextSibling"}return!0}if(o=[g?q.firstChild:q.lastChild],g&&s){m=q,l=m[u]||(m[u]={}),k=l[m.uniqueID]||(l[m.uniqueID]={}),j=k[a]||[],n=j[0]===w&&j[1],t=n&&j[2],m=n&&q.childNodes[n];while(m=++n&&m&&m[p]||(t=n=0)||o.pop())if(1===m.nodeType&&++t&&m===b){k[a]=[w,n,t];break}}else if(s&&(m=b,l=m[u]||(m[u]={}),k=l[m.uniqueID]||(l[m.uniqueID]={}),j=k[a]||[],n=j[0]===w&&j[1],t=n),t===!1)while(m=++n&&m&&m[p]||(t=n=0)||o.pop())if((h?m.nodeName.toLowerCase()===r:1===m.nodeType)&&++t&&(s&&(l=m[u]||(m[u]={}),k=l[m.uniqueID]||(l[m.uniqueID]={}),k[a]=[w,t]),m===b))break;return t-=e,t===d||t%d===0&&t/d>=0}}},PSEUDO:function(a,b){var c,e=d.pseudos[a]||d.setFilters[a.toLowerCase()]||ga.error("unsupported pseudo: "+a);return e[u]?e(b):e.length>1?(c=[a,a,"",b],d.setFilters.hasOwnProperty(a.toLowerCase())?ia(function(a,c){var d,f=e(a,b),g=f.length;while(g--)d=I(a,f[g]),a[d]=!(c[d]=f[g])}):function(a){return e(a,0,c)}):e}},pseudos:{not:ia(function(a){var b=[],c=[],d=h(a.replace(P,"$1"));return d[u]?ia(function(a,b,c,e){var f,g=d(a,null,e,[]),h=a.length;while(h--)(f=g[h])&&(a[h]=!(b[h]=f))}):function(a,e,f){return b[0]=a,d(b,null,f,c),b[0]=null,!c.pop()}}),has:ia(function(a){return function(b){return ga(a,b).length>0}}),contains:ia(function(a){return a=a.replace(_,aa),function(b){return(b.textContent||b.innerText||e(b)).indexOf(a)>-1}}),lang:ia(function(a){return U.test(a||"")||ga.error("unsupported lang: "+a),a=a.replace(_,aa).toLowerCase(),function(b){var c;do if(c=p?b.lang:b.getAttribute("xml:lang")||b.getAttribute("lang"))return c=c.toLowerCase(),c===a||0===c.indexOf(a+"-");while((b=b.parentNode)&&1===b.nodeType);return!1}}),target:function(b){var c=a.location&&a.location.hash;return c&&c.slice(1)===b.id},root:function(a){return a===o},focus:function(a){return a===n.activeElement&&(!n.hasFocus||n.hasFocus())&&!!(a.type||a.href||~a.tabIndex)},enabled:oa(!1),disabled:oa(!0),checked:function(a){var b=a.nodeName.toLowerCase();return"input"===b&&!!a.checked||"option"===b&&!!a.selected},selected:function(a){return a.parentNode&&a.parentNode.selectedIndex,a.selected===!0},empty:function(a){for(a=a.firstChild;a;a=a.nextSibling)if(a.nodeType<6)return!1;return!0},parent:function(a){return!d.pseudos.empty(a)},header:function(a){return X.test(a.nodeName)},input:function(a){return W.test(a.nodeName)},button:function(a){var b=a.nodeName.toLowerCase();return"input"===b&&"button"===a.type||"button"===b},text:function(a){var b;return"input"===a.nodeName.toLowerCase()&&"text"===a.type&&(null==(b=a.getAttribute("type"))||"text"===b.toLowerCase())},first:pa(function(){return[0]}),last:pa(function(a,b){return[b-1]}),eq:pa(function(a,b,c){return[c<0?c+b:c]}),even:pa(function(a,b){for(var c=0;c<b;c+=2)a.push(c);return a}),odd:pa(function(a,b){for(var c=1;c<b;c+=2)a.push(c);return a}),lt:pa(function(a,b,c){for(var d=c<0?c+b:c;--d>=0;)a.push(d);return a}),gt:pa(function(a,b,c){for(var d=c<0?c+b:c;++d<b;)a.push(d);return a})}},d.pseudos.nth=d.pseudos.eq;for(b in{radio:!0,checkbox:!0,file:!0,password:!0,image:!0})d.pseudos[b]=ma(b);for(b in{submit:!0,reset:!0})d.pseudos[b]=na(b);function ra(){}ra.prototype=d.filters=d.pseudos,d.setFilters=new ra,g=ga.tokenize=function(a,b){var c,e,f,g,h,i,j,k=z[a+" "];if(k)return b?0:k.slice(0);h=a,i=[],j=d.preFilter;while(h){c&&!(e=Q.exec(h))||(e&&(h=h.slice(e[0].length)||h),i.push(f=[])),c=!1,(e=R.exec(h))&&(c=e.shift(),f.push({value:c,type:e[0].replace(P," ")}),h=h.slice(c.length));for(g in d.filter)!(e=V[g].exec(h))||j[g]&&!(e=j[g](e))||(c=e.shift(),f.push({value:c,type:g,matches:e}),h=h.slice(c.length));if(!c)break}return b?h.length:h?ga.error(a):z(a,i).slice(0)};function sa(a){for(var b=0,c=a.length,d="";b<c;b++)d+=a[b].value;return d}function ta(a,b,c){var d=b.dir,e=b.next,f=e||d,g=c&&"parentNode"===f,h=x++;return b.first?function(b,c,e){while(b=b[d])if(1===b.nodeType||g)return a(b,c,e)}:function(b,c,i){var j,k,l,m=[w,h];if(i){while(b=b[d])if((1===b.nodeType||g)&&a(b,c,i))return!0}else while(b=b[d])if(1===b.nodeType||g)if(l=b[u]||(b[u]={}),k=l[b.uniqueID]||(l[b.uniqueID]={}),e&&e===b.nodeName.toLowerCase())b=b[d]||b;else{if((j=k[f])&&j[0]===w&&j[1]===h)return m[2]=j[2];if(k[f]=m,m[2]=a(b,c,i))return!0}}}function ua(a){return a.length>1?function(b,c,d){var e=a.length;while(e--)if(!a[e](b,c,d))return!1;return!0}:a[0]}function va(a,b,c){for(var d=0,e=b.length;d<e;d++)ga(a,b[d],c);return c}function wa(a,b,c,d,e){for(var f,g=[],h=0,i=a.length,j=null!=b;h<i;h++)(f=a[h])&&(c&&!c(f,d,e)||(g.push(f),j&&b.push(h)));return g}function xa(a,b,c,d,e,f){return d&&!d[u]&&(d=xa(d)),e&&!e[u]&&(e=xa(e,f)),ia(function(f,g,h,i){var j,k,l,m=[],n=[],o=g.length,p=f||va(b||"*",h.nodeType?[h]:h,[]),q=!a||!f&&b?p:wa(p,m,a,h,i),r=c?e||(f?a:o||d)?[]:g:q;if(c&&c(q,r,h,i),d){j=wa(r,n),d(j,[],h,i),k=j.length;while(k--)(l=j[k])&&(r[n[k]]=!(q[n[k]]=l))}if(f){if(e||a){if(e){j=[],k=r.length;while(k--)(l=r[k])&&j.push(q[k]=l);e(null,r=[],j,i)}k=r.length;while(k--)(l=r[k])&&(j=e?I(f,l):m[k])>-1&&(f[j]=!(g[j]=l))}}else r=wa(r===g?r.splice(o,r.length):r),e?e(null,g,r,i):G.apply(g,r)})}function ya(a){for(var b,c,e,f=a.length,g=d.relative[a[0].type],h=g||d.relative[" "],i=g?1:0,k=ta(function(a){return a===b},h,!0),l=ta(function(a){return I(b,a)>-1},h,!0),m=[function(a,c,d){var e=!g&&(d||c!==j)||((b=c).nodeType?k(a,c,d):l(a,c,d));return b=null,e}];i<f;i++)if(c=d.relative[a[i].type])m=[ta(ua(m),c)];else{if(c=d.filter[a[i].type].apply(null,a[i].matches),c[u]){for(e=++i;e<f;e++)if(d.relative[a[e].type])break;return xa(i>1&&ua(m),i>1&&sa(a.slice(0,i-1).concat({value:" "===a[i-2].type?"*":""})).replace(P,"$1"),c,i<e&&ya(a.slice(i,e)),e<f&&ya(a=a.slice(e)),e<f&&sa(a))}m.push(c)}return ua(m)}function za(a,b){var c=b.length>0,e=a.length>0,f=function(f,g,h,i,k){var l,o,q,r=0,s="0",t=f&&[],u=[],v=j,x=f||e&&d.find.TAG("*",k),y=w+=null==v?1:Math.random()||.1,z=x.length;for(k&&(j=g===n||g||k);s!==z&&null!=(l=x[s]);s++){if(e&&l){o=0,g||l.ownerDocument===n||(m(l),h=!p);while(q=a[o++])if(q(l,g||n,h)){i.push(l);break}k&&(w=y)}c&&((l=!q&&l)&&r--,f&&t.push(l))}if(r+=s,c&&s!==r){o=0;while(q=b[o++])q(t,u,g,h);if(f){if(r>0)while(s--)t[s]||u[s]||(u[s]=E.call(i));u=wa(u)}G.apply(i,u),k&&!f&&u.length>0&&r+b.length>1&&ga.uniqueSort(i)}return k&&(w=y,j=v),t};return c?ia(f):f}return h=ga.compile=function(a,b){var c,d=[],e=[],f=A[a+" "];if(!f){b||(b=g(a)),c=b.length;while(c--)f=ya(b[c]),f[u]?d.push(f):e.push(f);f=A(a,za(e,d)),f.selector=a}return f},i=ga.select=function(a,b,e,f){var i,j,k,l,m,n="function"==typeof a&&a,o=!f&&g(a=n.selector||a);if(e=e||[],1===o.length){if(j=o[0]=o[0].slice(0),j.length>2&&"ID"===(k=j[0]).type&&c.getById&&9===b.nodeType&&p&&d.relative[j[1].type]){if(b=(d.find.ID(k.matches[0].replace(_,aa),b)||[])[0],!b)return e;n&&(b=b.parentNode),a=a.slice(j.shift().value.length)}i=V.needsContext.test(a)?0:j.length;while(i--){if(k=j[i],d.relative[l=k.type])break;if((m=d.find[l])&&(f=m(k.matches[0].replace(_,aa),$.test(j[0].type)&&qa(b.parentNode)||b))){if(j.splice(i,1),a=f.length&&sa(j),!a)return G.apply(e,f),e;break}}}return(n||h(a,o))(f,b,!p,e,!b||$.test(a)&&qa(b.parentNode)||b),e},c.sortStable=u.split("").sort(B).join("")===u,c.detectDuplicates=!!l,m(),c.sortDetached=ja(function(a){return 1&a.compareDocumentPosition(n.createElement("fieldset"))}),ja(function(a){return a.innerHTML="<a href='#'></a>","#"===a.firstChild.getAttribute("href")})||ka("type|href|height|width",function(a,b,c){if(!c)return a.getAttribute(b,"type"===b.toLowerCase()?1:2)}),c.attributes&&ja(function(a){return a.innerHTML="<input/>",a.firstChild.setAttribute("value",""),""===a.firstChild.getAttribute("value")})||ka("value",function(a,b,c){if(!c&&"input"===a.nodeName.toLowerCase())return a.defaultValue}),ja(function(a){return null==a.getAttribute("disabled")})||ka(J,function(a,b,c){var d;if(!c)return a[b]===!0?b.toLowerCase():(d=a.getAttributeNode(b))&&d.specified?d.value:null}),ga}(a);r.find=x,r.expr=x.selectors,r.expr[":"]=r.expr.pseudos,r.uniqueSort=r.unique=x.uniqueSort,r.text=x.getText,r.isXMLDoc=x.isXML,r.contains=x.contains,r.escapeSelector=x.escape;var y=function(a,b,c){var d=[],e=void 0!==c;while((a=a[b])&&9!==a.nodeType)if(1===a.nodeType){if(e&&r(a).is(c))break;d.push(a)}return d},z=function(a,b){for(var c=[];a;a=a.nextSibling)1===a.nodeType&&a!==b&&c.push(a);return c},A=r.expr.match.needsContext,B=/^<([a-z][^\/\0>:\x20\t\r\n\f]*)[\x20\t\r\n\f]*\/?>(?:<\/\1>|)$/i,C=/^.[^:#\[\.,]*$/;function D(a,b,c){if(r.isFunction(b))return r.grep(a,function(a,d){return!!b.call(a,d,a)!==c});if(b.nodeType)return r.grep(a,function(a){return a===b!==c});if("string"==typeof b){if(C.test(b))return r.filter(b,a,c);b=r.filter(b,a)}return r.grep(a,function(a){return i.call(b,a)>-1!==c&&1===a.nodeType})}r.filter=function(a,b,c){var d=b[0];return c&&(a=":not("+a+")"),1===b.length&&1===d.nodeType?r.find.matchesSelector(d,a)?[d]:[]:r.find.matches(a,r.grep(b,function(a){return 1===a.nodeType}))},r.fn.extend({find:function(a){var b,c,d=this.length,e=this;if("string"!=typeof a)return this.pushStack(r(a).filter(function(){for(b=0;b<d;b++)if(r.contains(e[b],this))return!0}));for(c=this.pushStack([]),b=0;b<d;b++)r.find(a,e[b],c);return d>1?r.uniqueSort(c):c},filter:function(a){return this.pushStack(D(this,a||[],!1))},not:function(a){return this.pushStack(D(this,a||[],!0))},is:function(a){return!!D(this,"string"==typeof a&&A.test(a)?r(a):a||[],!1).length}});var E,F=/^(?:\s*(<[\w\W]+>)[^>]*|#([\w-]+))$/,G=r.fn.init=function(a,b,c){var e,f;if(!a)return this;if(c=c||E,"string"==typeof a){if(e="<"===a[0]&&">"===a[a.length-1]&&a.length>=3?[null,a,null]:F.exec(a),!e||!e[1]&&b)return!b||b.jquery?(b||c).find(a):this.constructor(b).find(a);if(e[1]){if(b=b instanceof r?b[0]:b,r.merge(this,r.parseHTML(e[1],b&&b.nodeType?b.ownerDocument||b:d,!0)),B.test(e[1])&&r.isPlainObject(b))for(e in b)r.isFunction(this[e])?this[e](b[e]):this.attr(e,b[e]);return this}return f=d.getElementById(e[2]),f&&(this[0]=f,this.length=1),this}return a.nodeType?(this[0]=a,this.length=1,this):r.isFunction(a)?void 0!==c.ready?c.ready(a):a(r):r.makeArray(a,this)};G.prototype=r.fn,E=r(d);var H=/^(?:parents|prev(?:Until|All))/,I={children:!0,contents:!0,next:!0,prev:!0};r.fn.extend({has:function(a){var b=r(a,this),c=b.length;return this.filter(function(){for(var a=0;a<c;a++)if(r.contains(this,b[a]))return!0})},closest:function(a,b){var c,d=0,e=this.length,f=[],g="string"!=typeof a&&r(a);if(!A.test(a))for(;d<e;d++)for(c=this[d];c&&c!==b;c=c.parentNode)if(c.nodeType<11&&(g?g.index(c)>-1:1===c.nodeType&&r.find.matchesSelector(c,a))){f.push(c);break}return this.pushStack(f.length>1?r.uniqueSort(f):f)},index:function(a){return a?"string"==typeof a?i.call(r(a),this[0]):i.call(this,a.jquery?a[0]:a):this[0]&&this[0].parentNode?this.first().prevAll().length:-1},add:function(a,b){return this.pushStack(r.uniqueSort(r.merge(this.get(),r(a,b))))},addBack:function(a){return this.add(null==a?this.prevObject:this.prevObject.filter(a))}});function J(a,b){while((a=a[b])&&1!==a.nodeType);return a}r.each({parent:function(a){var b=a.parentNode;return b&&11!==b.nodeType?b:null},parents:function(a){return y(a,"parentNode")},parentsUntil:function(a,b,c){return y(a,"parentNode",c)},next:function(a){return J(a,"nextSibling")},prev:function(a){return J(a,"previousSibling")},nextAll:function(a){return y(a,"nextSibling")},prevAll:function(a){return y(a,"previousSibling")},nextUntil:function(a,b,c){return y(a,"nextSibling",c)},prevUntil:function(a,b,c){return y(a,"previousSibling",c)},siblings:function(a){return z((a.parentNode||{}).firstChild,a)},children:function(a){return z(a.firstChild)},contents:function(a){return a.contentDocument||r.merge([],a.childNodes)}},function(a,b){r.fn[a]=function(c,d){var e=r.map(this,b,c);return"Until"!==a.slice(-5)&&(d=c),d&&"string"==typeof d&&(e=r.filter(d,e)),this.length>1&&(I[a]||r.uniqueSort(e),H.test(a)&&e.reverse()),this.pushStack(e)}});var K=/\S+/g;function L(a){var b={};return r.each(a.match(K)||[],function(a,c){b[c]=!0}),b}r.Callbacks=function(a){a="string"==typeof a?L(a):r.extend({},a);var b,c,d,e,f=[],g=[],h=-1,i=function(){for(e=a.once,d=b=!0;g.length;h=-1){c=g.shift();while(++h<f.length)f[h].apply(c[0],c[1])===!1&&a.stopOnFalse&&(h=f.length,c=!1)}a.memory||(c=!1),b=!1,e&&(f=c?[]:"")},j={add:function(){return f&&(c&&!b&&(h=f.length-1,g.push(c)),function d(b){r.each(b,function(b,c){r.isFunction(c)?a.unique&&j.has(c)||f.push(c):c&&c.length&&"string"!==r.type(c)&&d(c)})}(arguments),c&&!b&&i()),this},remove:function(){return r.each(arguments,function(a,b){var c;while((c=r.inArray(b,f,c))>-1)f.splice(c,1),c<=h&&h--}),this},has:function(a){return a?r.inArray(a,f)>-1:f.length>0},empty:function(){return f&&(f=[]),this},disable:function(){return e=g=[],f=c="",this},disabled:function(){return!f},lock:function(){return e=g=[],c||b||(f=c=""),this},locked:function(){return!!e},fireWith:function(a,c){return e||(c=c||[],c=[a,c.slice?c.slice():c],g.push(c),b||i()),this},fire:function(){return j.fireWith(this,arguments),this},fired:function(){return!!d}};return j};function M(a){return a}function N(a){throw a}function O(a,b,c){var d;try{a&&r.isFunction(d=a.promise)?d.call(a).done(b).fail(c):a&&r.isFunction(d=a.then)?d.call(a,b,c):b.call(void 0,a)}catch(a){c.call(void 0,a)}}r.extend({Deferred:function(b){var c=[["notify","progress",r.Callbacks("memory"),r.Callbacks("memory"),2],["resolve","done",r.Callbacks("once memory"),r.Callbacks("once memory"),0,"resolved"],["reject","fail",r.Callbacks("once memory"),r.Callbacks("once memory"),1,"rejected"]],d="pending",e={state:function(){return d},always:function(){return f.done(arguments).fail(arguments),this},"catch":function(a){return e.then(null,a)},pipe:function(){var a=arguments;return r.Deferred(function(b){r.each(c,function(c,d){var e=r.isFunction(a[d[4]])&&a[d[4]];f[d[1]](function(){var a=e&&e.apply(this,arguments);a&&r.isFunction(a.promise)?a.promise().progress(b.notify).done(b.resolve).fail(b.reject):b[d[0]+"With"](this,e?[a]:arguments)})}),a=null}).promise()},then:function(b,d,e){var f=0;function g(b,c,d,e){return function(){var h=this,i=arguments,j=function(){var a,j;if(!(b<f)){if(a=d.apply(h,i),a===c.promise())throw new TypeError("Thenable self-resolution");j=a&&("object"==typeof a||"function"==typeof a)&&a.then,r.isFunction(j)?e?j.call(a,g(f,c,M,e),g(f,c,N,e)):(f++,j.call(a,g(f,c,M,e),g(f,c,N,e),g(f,c,M,c.notifyWith))):(d!==M&&(h=void 0,i=[a]),(e||c.resolveWith)(h,i))}},k=e?j:function(){try{j()}catch(a){r.Deferred.exceptionHook&&r.Deferred.exceptionHook(a,k.stackTrace),b+1>=f&&(d!==N&&(h=void 0,i=[a]),c.rejectWith(h,i))}};b?k():(r.Deferred.getStackHook&&(k.stackTrace=r.Deferred.getStackHook()),a.setTimeout(k))}}return r.Deferred(function(a){c[0][3].add(g(0,a,r.isFunction(e)?e:M,a.notifyWith)),c[1][3].add(g(0,a,r.isFunction(b)?b:M)),c[2][3].add(g(0,a,r.isFunction(d)?d:N))}).promise()},promise:function(a){return null!=a?r.extend(a,e):e}},f={};return r.each(c,function(a,b){var g=b[2],h=b[5];e[b[1]]=g.add,h&&g.add(function(){d=h},c[3-a][2].disable,c[0][2].lock),g.add(b[3].fire),f[b[0]]=function(){return f[b[0]+"With"](this===f?void 0:this,arguments),this},f[b[0]+"With"]=g.fireWith}),e.promise(f),b&&b.call(f,f),f},when:function(a){var b=arguments.length,c=b,d=Array(c),e=f.call(arguments),g=r.Deferred(),h=function(a){return function(c){d[a]=this,e[a]=arguments.length>1?f.call(arguments):c,--b||g.resolveWith(d,e)}};if(b<=1&&(O(a,g.done(h(c)).resolve,g.reject),"pending"===g.state()||r.isFunction(e[c]&&e[c].then)))return g.then();while(c--)O(e[c],h(c),g.reject);return g.promise()}});var P=/^(Eval|Internal|Range|Reference|Syntax|Type|URI)Error$/;r.Deferred.exceptionHook=function(b,c){a.console&&a.console.warn&&b&&P.test(b.name)&&a.console.warn("jQuery.Deferred exception: "+b.message,b.stack,c)},r.readyException=function(b){a.setTimeout(function(){throw b})};var Q=r.Deferred();r.fn.ready=function(a){return Q.then(a)["catch"](function(a){r.readyException(a)}),this},r.extend({isReady:!1,readyWait:1,holdReady:function(a){a?r.readyWait++:r.ready(!0)},ready:function(a){(a===!0?--r.readyWait:r.isReady)||(r.isReady=!0,a!==!0&&--r.readyWait>0||Q.resolveWith(d,[r]))}}),r.ready.then=Q.then;function R(){d.removeEventListener("DOMContentLoaded",R),a.removeEventListener("load",R),r.ready()}"complete"===d.readyState||"loading"!==d.readyState&&!d.documentElement.doScroll?a.setTimeout(r.ready):(d.addEventListener("DOMContentLoaded",R), a.addEventListener("load",R));var S=function(a,b,c,d,e,f,g){var h=0,i=a.length,j=null==c;if("object"===r.type(c)){e=!0;for(h in c)S(a,b,h,c[h],!0,f,g)}else if(void 0!==d&&(e=!0,r.isFunction(d)||(g=!0),j&&(g?(b.call(a,d),b=null):(j=b,b=function(a,b,c){return j.call(r(a),c)})),b))for(;h<i;h++)b(a[h],c,g?d:d.call(a[h],h,b(a[h],c)));return e?a:j?b.call(a):i?b(a[0],c):f},T=function(a){return 1===a.nodeType||9===a.nodeType||!+a.nodeType};function U(){this.expando=r.expando+U.uid++}U.uid=1,U.prototype={cache:function(a){var b=a[this.expando];return b||(b={},T(a)&&(a.nodeType?a[this.expando]=b:Object.defineProperty(a,this.expando,{value:b,configurable:!0}))),b},set:function(a,b,c){var d,e=this.cache(a);if("string"==typeof b)e[r.camelCase(b)]=c;else for(d in b)e[r.camelCase(d)]=b[d];return e},get:function(a,b){return void 0===b?this.cache(a):a[this.expando]&&a[this.expando][r.camelCase(b)]},access:function(a,b,c){return void 0===b||b&&"string"==typeof b&&void 0===c?this.get(a,b):(this.set(a,b,c),void 0!==c?c:b)},remove:function(a,b){var c,d=a[this.expando];if(void 0!==d){if(void 0!==b){r.isArray(b)?b=b.map(r.camelCase):(b=r.camelCase(b),b=b in d?[b]:b.match(K)||[]),c=b.length;while(c--)delete d[b[c]]}(void 0===b||r.isEmptyObject(d))&&(a.nodeType?a[this.expando]=void 0:delete a[this.expando])}},hasData:function(a){var b=a[this.expando];return void 0!==b&&!r.isEmptyObject(b)}};var V=new U,W=new U,X=/^(?:\{[\w\W]*\}|\[[\w\W]*\])$/,Y=/[A-Z]/g;function Z(a,b,c){var d;if(void 0===c&&1===a.nodeType)if(d="data-"+b.replace(Y,"-$&").toLowerCase(),c=a.getAttribute(d),"string"==typeof c){try{c="true"===c||"false"!==c&&("null"===c?null:+c+""===c?+c:X.test(c)?JSON.parse(c):c)}catch(e){}W.set(a,b,c)}else c=void 0;return c}r.extend({hasData:function(a){return W.hasData(a)||V.hasData(a)},data:function(a,b,c){return W.access(a,b,c)},removeData:function(a,b){W.remove(a,b)},_data:function(a,b,c){return V.access(a,b,c)},_removeData:function(a,b){V.remove(a,b)}}),r.fn.extend({data:function(a,b){var c,d,e,f=this[0],g=f&&f.attributes;if(void 0===a){if(this.length&&(e=W.get(f),1===f.nodeType&&!V.get(f,"hasDataAttrs"))){c=g.length;while(c--)g[c]&&(d=g[c].name,0===d.indexOf("data-")&&(d=r.camelCase(d.slice(5)),Z(f,d,e[d])));V.set(f,"hasDataAttrs",!0)}return e}return"object"==typeof a?this.each(function(){W.set(this,a)}):S(this,function(b){var c;if(f&&void 0===b){if(c=W.get(f,a),void 0!==c)return c;if(c=Z(f,a),void 0!==c)return c}else this.each(function(){W.set(this,a,b)})},null,b,arguments.length>1,null,!0)},removeData:function(a){return this.each(function(){W.remove(this,a)})}}),r.extend({queue:function(a,b,c){var d;if(a)return b=(b||"fx")+"queue",d=V.get(a,b),c&&(!d||r.isArray(c)?d=V.access(a,b,r.makeArray(c)):d.push(c)),d||[]},dequeue:function(a,b){b=b||"fx";var c=r.queue(a,b),d=c.length,e=c.shift(),f=r._queueHooks(a,b),g=function(){r.dequeue(a,b)};"inprogress"===e&&(e=c.shift(),d--),e&&("fx"===b&&c.unshift("inprogress"),delete f.stop,e.call(a,g,f)),!d&&f&&f.empty.fire()},_queueHooks:function(a,b){var c=b+"queueHooks";return V.get(a,c)||V.access(a,c,{empty:r.Callbacks("once memory").add(function(){V.remove(a,[b+"queue",c])})})}}),r.fn.extend({queue:function(a,b){var c=2;return"string"!=typeof a&&(b=a,a="fx",c--),arguments.length<c?r.queue(this[0],a):void 0===b?this:this.each(function(){var c=r.queue(this,a,b);r._queueHooks(this,a),"fx"===a&&"inprogress"!==c[0]&&r.dequeue(this,a)})},dequeue:function(a){return this.each(function(){r.dequeue(this,a)})},clearQueue:function(a){return this.queue(a||"fx",[])},promise:function(a,b){var c,d=1,e=r.Deferred(),f=this,g=this.length,h=function(){--d||e.resolveWith(f,[f])};"string"!=typeof a&&(b=a,a=void 0),a=a||"fx";while(g--)c=V.get(f[g],a+"queueHooks"),c&&c.empty&&(d++,c.empty.add(h));return h(),e.promise(b)}});var $=/[+-]?(?:\d*\.|)\d+(?:[eE][+-]?\d+|)/.source,_=new RegExp("^(?:([+-])=|)("+$+")([a-z%]*)$","i"),aa=["Top","Right","Bottom","Left"],ba=function(a,b){return a=b||a,"none"===a.style.display||""===a.style.display&&r.contains(a.ownerDocument,a)&&"none"===r.css(a,"display")},ca=function(a,b,c,d){var e,f,g={};for(f in b)g[f]=a.style[f],a.style[f]=b[f];e=c.apply(a,d||[]);for(f in b)a.style[f]=g[f];return e};function da(a,b,c,d){var e,f=1,g=20,h=d?function(){return d.cur()}:function(){return r.css(a,b,"")},i=h(),j=c&&c[3]||(r.cssNumber[b]?"":"px"),k=(r.cssNumber[b]||"px"!==j&&+i)&&_.exec(r.css(a,b));if(k&&k[3]!==j){j=j||k[3],c=c||[],k=+i||1;do f=f||".5",k/=f,r.style(a,b,k+j);while(f!==(f=h()/i)&&1!==f&&--g)}return c&&(k=+k||+i||0,e=c[1]?k+(c[1]+1)*c[2]:+c[2],d&&(d.unit=j,d.start=k,d.end=e)),e}var ea={};function fa(a){var b,c=a.ownerDocument,d=a.nodeName,e=ea[d];return e?e:(b=c.body.appendChild(c.createElement(d)),e=r.css(b,"display"),b.parentNode.removeChild(b),"none"===e&&(e="block"),ea[d]=e,e)}function ga(a,b){for(var c,d,e=[],f=0,g=a.length;f<g;f++)d=a[f],d.style&&(c=d.style.display,b?("none"===c&&(e[f]=V.get(d,"display")||null,e[f]||(d.style.display="")),""===d.style.display&&ba(d)&&(e[f]=fa(d))):"none"!==c&&(e[f]="none",V.set(d,"display",c)));for(f=0;f<g;f++)null!=e[f]&&(a[f].style.display=e[f]);return a}r.fn.extend({show:function(){return ga(this,!0)},hide:function(){return ga(this)},toggle:function(a){return"boolean"==typeof a?a?this.show():this.hide():this.each(function(){ba(this)?r(this).show():r(this).hide()})}});var ha=/^(?:checkbox|radio)$/i,ia=/<([a-z][^\/\0>\x20\t\r\n\f]+)/i,ja=/^$|\/(?:java|ecma)script/i,ka={option:[1,"<select multiple='multiple'>","</select>"],thead:[1,"<table>","</table>"],col:[2,"<table><colgroup>","</colgroup></table>"],tr:[2,"<table><tbody>","</tbody></table>"],td:[3,"<table><tbody><tr>","</tr></tbody></table>"],_default:[0,"",""]};ka.optgroup=ka.option,ka.tbody=ka.tfoot=ka.colgroup=ka.caption=ka.thead,ka.th=ka.td;function la(a,b){var c="undefined"!=typeof a.getElementsByTagName?a.getElementsByTagName(b||"*"):"undefined"!=typeof a.querySelectorAll?a.querySelectorAll(b||"*"):[];return void 0===b||b&&r.nodeName(a,b)?r.merge([a],c):c}function ma(a,b){for(var c=0,d=a.length;c<d;c++)V.set(a[c],"globalEval",!b||V.get(b[c],"globalEval"))}var na=/<|&#?\w+;/;function oa(a,b,c,d,e){for(var f,g,h,i,j,k,l=b.createDocumentFragment(),m=[],n=0,o=a.length;n<o;n++)if(f=a[n],f||0===f)if("object"===r.type(f))r.merge(m,f.nodeType?[f]:f);else if(na.test(f)){g=g||l.appendChild(b.createElement("div")),h=(ia.exec(f)||["",""])[1].toLowerCase(),i=ka[h]||ka._default,g.innerHTML=i[1]+r.htmlPrefilter(f)+i[2],k=i[0];while(k--)g=g.lastChild;r.merge(m,g.childNodes),g=l.firstChild,g.textContent=""}else m.push(b.createTextNode(f));l.textContent="",n=0;while(f=m[n++])if(d&&r.inArray(f,d)>-1)e&&e.push(f);else if(j=r.contains(f.ownerDocument,f),g=la(l.appendChild(f),"script"),j&&ma(g),c){k=0;while(f=g[k++])ja.test(f.type||"")&&c.push(f)}return l}!function(){var a=d.createDocumentFragment(),b=a.appendChild(d.createElement("div")),c=d.createElement("input");c.setAttribute("type","radio"),c.setAttribute("checked","checked"),c.setAttribute("name","t"),b.appendChild(c),o.checkClone=b.cloneNode(!0).cloneNode(!0).lastChild.checked,b.innerHTML="<textarea>x</textarea>",o.noCloneChecked=!!b.cloneNode(!0).lastChild.defaultValue}();var pa=d.documentElement,qa=/^key/,ra=/^(?:mouse|pointer|contextmenu|drag|drop)|click/,sa=/^([^.]*)(?:\.(.+)|)/;function ta(){return!0}function ua(){return!1}function va(){try{return d.activeElement}catch(a){}}function wa(a,b,c,d,e,f){var g,h;if("object"==typeof b){"string"!=typeof c&&(d=d||c,c=void 0);for(h in b)wa(a,h,c,d,b[h],f);return a}if(null==d&&null==e?(e=c,d=c=void 0):null==e&&("string"==typeof c?(e=d,d=void 0):(e=d,d=c,c=void 0)),e===!1)e=ua;else if(!e)return a;return 1===f&&(g=e,e=function(a){return r().off(a),g.apply(this,arguments)},e.guid=g.guid||(g.guid=r.guid++)),a.each(function(){r.event.add(this,b,e,d,c)})}r.event={global:{},add:function(a,b,c,d,e){var f,g,h,i,j,k,l,m,n,o,p,q=V.get(a);if(q){c.handler&&(f=c,c=f.handler,e=f.selector),e&&r.find.matchesSelector(pa,e),c.guid||(c.guid=r.guid++),(i=q.events)||(i=q.events={}),(g=q.handle)||(g=q.handle=function(b){return"undefined"!=typeof r&&r.event.triggered!==b.type?r.event.dispatch.apply(a,arguments):void 0}),b=(b||"").match(K)||[""],j=b.length;while(j--)h=sa.exec(b[j])||[],n=p=h[1],o=(h[2]||"").split(".").sort(),n&&(l=r.event.special[n]||{},n=(e?l.delegateType:l.bindType)||n,l=r.event.special[n]||{},k=r.extend({type:n,origType:p,data:d,handler:c,guid:c.guid,selector:e,needsContext:e&&r.expr.match.needsContext.test(e),namespace:o.join(".")},f),(m=i[n])||(m=i[n]=[],m.delegateCount=0,l.setup&&l.setup.call(a,d,o,g)!==!1||a.addEventListener&&a.addEventListener(n,g)),l.add&&(l.add.call(a,k),k.handler.guid||(k.handler.guid=c.guid)),e?m.splice(m.delegateCount++,0,k):m.push(k),r.event.global[n]=!0)}},remove:function(a,b,c,d,e){var f,g,h,i,j,k,l,m,n,o,p,q=V.hasData(a)&&V.get(a);if(q&&(i=q.events)){b=(b||"").match(K)||[""],j=b.length;while(j--)if(h=sa.exec(b[j])||[],n=p=h[1],o=(h[2]||"").split(".").sort(),n){l=r.event.special[n]||{},n=(d?l.delegateType:l.bindType)||n,m=i[n]||[],h=h[2]&&new RegExp("(^|\\.)"+o.join("\\.(?:.*\\.|)")+"(\\.|$)"),g=f=m.length;while(f--)k=m[f],!e&&p!==k.origType||c&&c.guid!==k.guid||h&&!h.test(k.namespace)||d&&d!==k.selector&&("**"!==d||!k.selector)||(m.splice(f,1),k.selector&&m.delegateCount--,l.remove&&l.remove.call(a,k));g&&!m.length&&(l.teardown&&l.teardown.call(a,o,q.handle)!==!1||r.removeEvent(a,n,q.handle),delete i[n])}else for(n in i)r.event.remove(a,n+b[j],c,d,!0);r.isEmptyObject(i)&&V.remove(a,"handle events")}},dispatch:function(a){var b=r.event.fix(a),c,d,e,f,g,h,i=new Array(arguments.length),j=(V.get(this,"events")||{})[b.type]||[],k=r.event.special[b.type]||{};for(i[0]=b,c=1;c<arguments.length;c++)i[c]=arguments[c];if(b.delegateTarget=this,!k.preDispatch||k.preDispatch.call(this,b)!==!1){h=r.event.handlers.call(this,b,j),c=0;while((f=h[c++])&&!b.isPropagationStopped()){b.currentTarget=f.elem,d=0;while((g=f.handlers[d++])&&!b.isImmediatePropagationStopped())b.rnamespace&&!b.rnamespace.test(g.namespace)||(b.handleObj=g,b.data=g.data,e=((r.event.special[g.origType]||{}).handle||g.handler).apply(f.elem,i),void 0!==e&&(b.result=e)===!1&&(b.preventDefault(),b.stopPropagation()))}return k.postDispatch&&k.postDispatch.call(this,b),b.result}},handlers:function(a,b){var c,d,e,f,g=[],h=b.delegateCount,i=a.target;if(h&&i.nodeType&&("click"!==a.type||isNaN(a.button)||a.button<1))for(;i!==this;i=i.parentNode||this)if(1===i.nodeType&&(i.disabled!==!0||"click"!==a.type)){for(d=[],c=0;c<h;c++)f=b[c],e=f.selector+" ",void 0===d[e]&&(d[e]=f.needsContext?r(e,this).index(i)>-1:r.find(e,this,null,[i]).length),d[e]&&d.push(f);d.length&&g.push({elem:i,handlers:d})}return h<b.length&&g.push({elem:this,handlers:b.slice(h)}),g},addProp:function(a,b){Object.defineProperty(r.Event.prototype,a,{enumerable:!0,configurable:!0,get:r.isFunction(b)?function(){if(this.originalEvent)return b(this.originalEvent)}:function(){if(this.originalEvent)return this.originalEvent[a]},set:function(b){Object.defineProperty(this,a,{enumerable:!0,configurable:!0,writable:!0,value:b})}})},fix:function(a){return a[r.expando]?a:new r.Event(a)},special:{load:{noBubble:!0},focus:{trigger:function(){if(this!==va()&&this.focus)return this.focus(),!1},delegateType:"focusin"},blur:{trigger:function(){if(this===va()&&this.blur)return this.blur(),!1},delegateType:"focusout"},click:{trigger:function(){if("checkbox"===this.type&&this.click&&r.nodeName(this,"input"))return this.click(),!1},_default:function(a){return r.nodeName(a.target,"a")}},beforeunload:{postDispatch:function(a){void 0!==a.result&&a.originalEvent&&(a.originalEvent.returnValue=a.result)}}}},r.removeEvent=function(a,b,c){a.removeEventListener&&a.removeEventListener(b,c)},r.Event=function(a,b){return this instanceof r.Event?(a&&a.type?(this.originalEvent=a,this.type=a.type,this.isDefaultPrevented=a.defaultPrevented||void 0===a.defaultPrevented&&a.returnValue===!1?ta:ua,this.target=a.target&&3===a.target.nodeType?a.target.parentNode:a.target,this.currentTarget=a.currentTarget,this.relatedTarget=a.relatedTarget):this.type=a,b&&r.extend(this,b),this.timeStamp=a&&a.timeStamp||r.now(),void(this[r.expando]=!0)):new r.Event(a,b)},r.Event.prototype={constructor:r.Event,isDefaultPrevented:ua,isPropagationStopped:ua,isImmediatePropagationStopped:ua,isSimulated:!1,preventDefault:function(){var a=this.originalEvent;this.isDefaultPrevented=ta,a&&!this.isSimulated&&a.preventDefault()},stopPropagation:function(){var a=this.originalEvent;this.isPropagationStopped=ta,a&&!this.isSimulated&&a.stopPropagation()},stopImmediatePropagation:function(){var a=this.originalEvent;this.isImmediatePropagationStopped=ta,a&&!this.isSimulated&&a.stopImmediatePropagation(),this.stopPropagation()}},r.each({altKey:!0,bubbles:!0,cancelable:!0,changedTouches:!0,ctrlKey:!0,detail:!0,eventPhase:!0,metaKey:!0,pageX:!0,pageY:!0,shiftKey:!0,view:!0,"char":!0,charCode:!0,key:!0,keyCode:!0,button:!0,buttons:!0,clientX:!0,clientY:!0,offsetX:!0,offsetY:!0,pointerId:!0,pointerType:!0,screenX:!0,screenY:!0,targetTouches:!0,toElement:!0,touches:!0,which:function(a){var b=a.button;return null==a.which&&qa.test(a.type)?null!=a.charCode?a.charCode:a.keyCode:!a.which&&void 0!==b&&ra.test(a.type)?1&b?1:2&b?3:4&b?2:0:a.which}},r.event.addProp),r.each({mouseenter:"mouseover",mouseleave:"mouseout",pointerenter:"pointerover",pointerleave:"pointerout"},function(a,b){r.event.special[a]={delegateType:b,bindType:b,handle:function(a){var c,d=this,e=a.relatedTarget,f=a.handleObj;return e&&(e===d||r.contains(d,e))||(a.type=f.origType,c=f.handler.apply(this,arguments),a.type=b),c}}}),r.fn.extend({on:function(a,b,c,d){return wa(this,a,b,c,d)},one:function(a,b,c,d){return wa(this,a,b,c,d,1)},off:function(a,b,c){var d,e;if(a&&a.preventDefault&&a.handleObj)return d=a.handleObj,r(a.delegateTarget).off(d.namespace?d.origType+"."+d.namespace:d.origType,d.selector,d.handler),this;if("object"==typeof a){for(e in a)this.off(e,b,a[e]);return this}return b!==!1&&"function"!=typeof b||(c=b,b=void 0),c===!1&&(c=ua),this.each(function(){r.event.remove(this,a,c,b)})}});var xa=/<(?!area|br|col|embed|hr|img|input|link|meta|param)(([a-z][^\/\0>\x20\t\r\n\f]*)[^>]*)\/>/gi,ya=/<script|<style|<link/i,za=/checked\s*(?:[^=]|=\s*.checked.)/i,Aa=/^true\/(.*)/,Ba=/^\s*<!(?:\[CDATA\[|--)|(?:\]\]|--)>\s*$/g;function Ca(a,b){return r.nodeName(a,"table")&&r.nodeName(11!==b.nodeType?b:b.firstChild,"tr")?a.getElementsByTagName("tbody")[0]||a:a}function Da(a){return a.type=(null!==a.getAttribute("type"))+"/"+a.type,a}function Ea(a){var b=Aa.exec(a.type);return b?a.type=b[1]:a.removeAttribute("type"),a}function Fa(a,b){var c,d,e,f,g,h,i,j;if(1===b.nodeType){if(V.hasData(a)&&(f=V.access(a),g=V.set(b,f),j=f.events)){delete g.handle,g.events={};for(e in j)for(c=0,d=j[e].length;c<d;c++)r.event.add(b,e,j[e][c])}W.hasData(a)&&(h=W.access(a),i=r.extend({},h),W.set(b,i))}}function Ga(a,b){var c=b.nodeName.toLowerCase();"input"===c&&ha.test(a.type)?b.checked=a.checked:"input"!==c&&"textarea"!==c||(b.defaultValue=a.defaultValue)}function Ha(a,b,c,d){b=g.apply([],b);var e,f,h,i,j,k,l=0,m=a.length,n=m-1,q=b[0],s=r.isFunction(q);if(s||m>1&&"string"==typeof q&&!o.checkClone&&za.test(q))return a.each(function(e){var f=a.eq(e);s&&(b[0]=q.call(this,e,f.html())),Ha(f,b,c,d)});if(m&&(e=oa(b,a[0].ownerDocument,!1,a,d),f=e.firstChild,1===e.childNodes.length&&(e=f),f||d)){for(h=r.map(la(e,"script"),Da),i=h.length;l<m;l++)j=e,l!==n&&(j=r.clone(j,!0,!0),i&&r.merge(h,la(j,"script"))),c.call(a[l],j,l);if(i)for(k=h[h.length-1].ownerDocument,r.map(h,Ea),l=0;l<i;l++)j=h[l],ja.test(j.type||"")&&!V.access(j,"globalEval")&&r.contains(k,j)&&(j.src?r._evalUrl&&r._evalUrl(j.src):p(j.textContent.replace(Ba,""),k))}return a}function Ia(a,b,c){for(var d,e=b?r.filter(b,a):a,f=0;null!=(d=e[f]);f++)c||1!==d.nodeType||r.cleanData(la(d)),d.parentNode&&(c&&r.contains(d.ownerDocument,d)&&ma(la(d,"script")),d.parentNode.removeChild(d));return a}r.extend({htmlPrefilter:function(a){return a.replace(xa,"<$1></$2>")},clone:function(a,b,c){var d,e,f,g,h=a.cloneNode(!0),i=r.contains(a.ownerDocument,a);if(!(o.noCloneChecked||1!==a.nodeType&&11!==a.nodeType||r.isXMLDoc(a)))for(g=la(h),f=la(a),d=0,e=f.length;d<e;d++)Ga(f[d],g[d]);if(b)if(c)for(f=f||la(a),g=g||la(h),d=0,e=f.length;d<e;d++)Fa(f[d],g[d]);else Fa(a,h);return g=la(h,"script"),g.length>0&&ma(g,!i&&la(a,"script")),h},cleanData:function(a){for(var b,c,d,e=r.event.special,f=0;void 0!==(c=a[f]);f++)if(T(c)){if(b=c[V.expando]){if(b.events)for(d in b.events)e[d]?r.event.remove(c,d):r.removeEvent(c,d,b.handle);c[V.expando]=void 0}c[W.expando]&&(c[W.expando]=void 0)}}}),r.fn.extend({detach:function(a){return Ia(this,a,!0)},remove:function(a){return Ia(this,a)},text:function(a){return S(this,function(a){return void 0===a?r.text(this):this.empty().each(function(){1!==this.nodeType&&11!==this.nodeType&&9!==this.nodeType||(this.textContent=a)})},null,a,arguments.length)},append:function(){return Ha(this,arguments,function(a){if(1===this.nodeType||11===this.nodeType||9===this.nodeType){var b=Ca(this,a);b.appendChild(a)}})},prepend:function(){return Ha(this,arguments,function(a){if(1===this.nodeType||11===this.nodeType||9===this.nodeType){var b=Ca(this,a);b.insertBefore(a,b.firstChild)}})},before:function(){return Ha(this,arguments,function(a){this.parentNode&&this.parentNode.insertBefore(a,this)})},after:function(){return Ha(this,arguments,function(a){this.parentNode&&this.parentNode.insertBefore(a,this.nextSibling)})},empty:function(){for(var a,b=0;null!=(a=this[b]);b++)1===a.nodeType&&(r.cleanData(la(a,!1)),a.textContent="");return this},clone:function(a,b){return a=null!=a&&a,b=null==b?a:b,this.map(function(){return r.clone(this,a,b)})},html:function(a){return S(this,function(a){var b=this[0]||{},c=0,d=this.length;if(void 0===a&&1===b.nodeType)return b.innerHTML;if("string"==typeof a&&!ya.test(a)&&!ka[(ia.exec(a)||["",""])[1].toLowerCase()]){a=r.htmlPrefilter(a);try{for(;c<d;c++)b=this[c]||{},1===b.nodeType&&(r.cleanData(la(b,!1)),b.innerHTML=a);b=0}catch(e){}}b&&this.empty().append(a)},null,a,arguments.length)},replaceWith:function(){var a=[];return Ha(this,arguments,function(b){var c=this.parentNode;r.inArray(this,a)<0&&(r.cleanData(la(this)),c&&c.replaceChild(b,this))},a)}}),r.each({appendTo:"append",prependTo:"prepend",insertBefore:"before",insertAfter:"after",replaceAll:"replaceWith"},function(a,b){r.fn[a]=function(a){for(var c,d=[],e=r(a),f=e.length-1,g=0;g<=f;g++)c=g===f?this:this.clone(!0),r(e[g])[b](c),h.apply(d,c.get());return this.pushStack(d)}});var Ja=/^margin/,Ka=new RegExp("^("+$+")(?!px)[a-z%]+$","i"),La=function(b){var c=b.ownerDocument.defaultView;return c&&c.opener||(c=a),c.getComputedStyle(b)};!function(){function b(){if(i){i.style.cssText="box-sizing:border-box;position:relative;display:block;margin:auto;border:1px;padding:1px;top:1%;width:50%",i.innerHTML="",pa.appendChild(h);var b=a.getComputedStyle(i);c="1%"!==b.top,g="2px"===b.marginLeft,e="4px"===b.width,i.style.marginRight="50%",f="4px"===b.marginRight,pa.removeChild(h),i=null}}var c,e,f,g,h=d.createElement("div"),i=d.createElement("div");i.style&&(i.style.backgroundClip="content-box",i.cloneNode(!0).style.backgroundClip="",o.clearCloneStyle="content-box"===i.style.backgroundClip,h.style.cssText="border:0;width:8px;height:0;top:0;left:-9999px;padding:0;margin-top:1px;position:absolute",h.appendChild(i),r.extend(o,{pixelPosition:function(){return b(),c},boxSizingReliable:function(){return b(),e},pixelMarginRight:function(){return b(),f},reliableMarginLeft:function(){return b(),g}}))}();function Ma(a,b,c){var d,e,f,g,h=a.style;return c=c||La(a),c&&(g=c.getPropertyValue(b)||c[b],""!==g||r.contains(a.ownerDocument,a)||(g=r.style(a,b)),!o.pixelMarginRight()&&Ka.test(g)&&Ja.test(b)&&(d=h.width,e=h.minWidth,f=h.maxWidth,h.minWidth=h.maxWidth=h.width=g,g=c.width,h.width=d,h.minWidth=e,h.maxWidth=f)),void 0!==g?g+"":g}function Na(a,b){return{get:function(){return a()?void delete this.get:(this.get=b).apply(this,arguments)}}}var Oa=/^(none|table(?!-c[ea]).+)/,Pa={position:"absolute",visibility:"hidden",display:"block"},Qa={letterSpacing:"0",fontWeight:"400"},Ra=["Webkit","Moz","ms"],Sa=d.createElement("div").style;function Ta(a){if(a in Sa)return a;var b=a[0].toUpperCase()+a.slice(1),c=Ra.length;while(c--)if(a=Ra[c]+b,a in Sa)return a}function Ua(a,b,c){var d=_.exec(b);return d?Math.max(0,d[2]-(c||0))+(d[3]||"px"):b}function Va(a,b,c,d,e){for(var f=c===(d?"border":"content")?4:"width"===b?1:0,g=0;f<4;f+=2)"margin"===c&&(g+=r.css(a,c+aa[f],!0,e)),d?("content"===c&&(g-=r.css(a,"padding"+aa[f],!0,e)),"margin"!==c&&(g-=r.css(a,"border"+aa[f]+"Width",!0,e))):(g+=r.css(a,"padding"+aa[f],!0,e),"padding"!==c&&(g+=r.css(a,"border"+aa[f]+"Width",!0,e)));return g}function Wa(a,b,c){var d,e=!0,f=La(a),g="border-box"===r.css(a,"boxSizing",!1,f);if(a.getClientRects().length&&(d=a.getBoundingClientRect()[b]),d<=0||null==d){if(d=Ma(a,b,f),(d<0||null==d)&&(d=a.style[b]),Ka.test(d))return d;e=g&&(o.boxSizingReliable()||d===a.style[b]),d=parseFloat(d)||0}return d+Va(a,b,c||(g?"border":"content"),e,f)+"px"}r.extend({cssHooks:{opacity:{get:function(a,b){if(b){var c=Ma(a,"opacity");return""===c?"1":c}}}},cssNumber:{animationIterationCount:!0,columnCount:!0,fillOpacity:!0,flexGrow:!0,flexShrink:!0,fontWeight:!0,lineHeight:!0,opacity:!0,order:!0,orphans:!0,widows:!0,zIndex:!0,zoom:!0},cssProps:{"float":"cssFloat"},style:function(a,b,c,d){if(a&&3!==a.nodeType&&8!==a.nodeType&&a.style){var e,f,g,h=r.camelCase(b),i=a.style;return b=r.cssProps[h]||(r.cssProps[h]=Ta(h)||h),g=r.cssHooks[b]||r.cssHooks[h],void 0===c?g&&"get"in g&&void 0!==(e=g.get(a,!1,d))?e:i[b]:(f=typeof c,"string"===f&&(e=_.exec(c))&&e[1]&&(c=da(a,b,e),f="number"),null!=c&&c===c&&("number"===f&&(c+=e&&e[3]||(r.cssNumber[h]?"":"px")),o.clearCloneStyle||""!==c||0!==b.indexOf("background")||(i[b]="inherit"),g&&"set"in g&&void 0===(c=g.set(a,c,d))||(i[b]=c)),void 0)}},css:function(a,b,c,d){var e,f,g,h=r.camelCase(b);return b=r.cssProps[h]||(r.cssProps[h]=Ta(h)||h),g=r.cssHooks[b]||r.cssHooks[h],g&&"get"in g&&(e=g.get(a,!0,c)),void 0===e&&(e=Ma(a,b,d)),"normal"===e&&b in Qa&&(e=Qa[b]),""===c||c?(f=parseFloat(e),c===!0||isFinite(f)?f||0:e):e}}),r.each(["height","width"],function(a,b){r.cssHooks[b]={get:function(a,c,d){if(c)return!Oa.test(r.css(a,"display"))||a.getClientRects().length&&a.getBoundingClientRect().width?Wa(a,b,d):ca(a,Pa,function(){return Wa(a,b,d)})},set:function(a,c,d){var e,f=d&&La(a),g=d&&Va(a,b,d,"border-box"===r.css(a,"boxSizing",!1,f),f);return g&&(e=_.exec(c))&&"px"!==(e[3]||"px")&&(a.style[b]=c,c=r.css(a,b)),Ua(a,c,g)}}}),r.cssHooks.marginLeft=Na(o.reliableMarginLeft,function(a,b){if(b)return(parseFloat(Ma(a,"marginLeft"))||a.getBoundingClientRect().left-ca(a,{marginLeft:0},function(){return a.getBoundingClientRect().left}))+"px"}),r.each({margin:"",padding:"",border:"Width"},function(a,b){r.cssHooks[a+b]={expand:function(c){for(var d=0,e={},f="string"==typeof c?c.split(" "):[c];d<4;d++)e[a+aa[d]+b]=f[d]||f[d-2]||f[0];return e}},Ja.test(a)||(r.cssHooks[a+b].set=Ua)}),r.fn.extend({css:function(a,b){return S(this,function(a,b,c){var d,e,f={},g=0;if(r.isArray(b)){for(d=La(a),e=b.length;g<e;g++)f[b[g]]=r.css(a,b[g],!1,d);return f}return void 0!==c?r.style(a,b,c):r.css(a,b)},a,b,arguments.length>1)}}),r.fn.delay=function(b,c){return b=r.fx?r.fx.speeds[b]||b:b,c=c||"fx",this.queue(c,function(c,d){var e=a.setTimeout(c,b);d.stop=function(){a.clearTimeout(e)}})},function(){var a=d.createElement("input"),b=d.createElement("select"),c=b.appendChild(d.createElement("option"));a.type="checkbox",o.checkOn=""!==a.value,o.optSelected=c.selected,a=d.createElement("input"),a.value="t",a.type="radio",o.radioValue="t"===a.value}();var Xa,Ya=r.expr.attrHandle;r.fn.extend({attr:function(a,b){return S(this,r.attr,a,b,arguments.length>1)},removeAttr:function(a){return this.each(function(){r.removeAttr(this,a)})}}),r.extend({attr:function(a,b,c){var d,e,f=a.nodeType;if(3!==f&&8!==f&&2!==f)return"undefined"==typeof a.getAttribute?r.prop(a,b,c):(1===f&&r.isXMLDoc(a)||(e=r.attrHooks[b.toLowerCase()]||(r.expr.match.bool.test(b)?Xa:void 0)),void 0!==c?null===c?void r.removeAttr(a,b):e&&"set"in e&&void 0!==(d=e.set(a,c,b))?d:(a.setAttribute(b,c+""),c):e&&"get"in e&&null!==(d=e.get(a,b))?d:(d=r.find.attr(a,b),null==d?void 0:d))},attrHooks:{type:{set:function(a,b){if(!o.radioValue&&"radio"===b&&r.nodeName(a,"input")){var c=a.value;return a.setAttribute("type",b),c&&(a.value=c),b}}}},removeAttr:function(a,b){var c,d=0,e=b&&b.match(K);if(e&&1===a.nodeType)while(c=e[d++])a.removeAttribute(c)}}),Xa={set:function(a,b,c){return b===!1?r.removeAttr(a,c):a.setAttribute(c,c),c}},r.each(r.expr.match.bool.source.match(/\w+/g),function(a,b){var c=Ya[b]||r.find.attr;Ya[b]=function(a,b,d){var e,f,g=b.toLowerCase();return d||(f=Ya[g],Ya[g]=e,e=null!=c(a,b,d)?g:null,Ya[g]=f),e}});var Za=/^(?:input|select|textarea|button)$/i,$a=/^(?:a|area)$/i;r.fn.extend({prop:function(a,b){return S(this,r.prop,a,b,arguments.length>1)},removeProp:function(a){return this.each(function(){delete this[r.propFix[a]||a]})}}),r.extend({prop:function(a,b,c){var d,e,f=a.nodeType;if(3!==f&&8!==f&&2!==f)return 1===f&&r.isXMLDoc(a)||(b=r.propFix[b]||b,e=r.propHooks[b]),void 0!==c?e&&"set"in e&&void 0!==(d=e.set(a,c,b))?d:a[b]=c:e&&"get"in e&&null!==(d=e.get(a,b))?d:a[b]},propHooks:{tabIndex:{get:function(a){var b=r.find.attr(a,"tabindex");return b?parseInt(b,10):Za.test(a.nodeName)||$a.test(a.nodeName)&&a.href?0:-1}}},propFix:{"for":"htmlFor","class":"className"}}),o.optSelected||(r.propHooks.selected={get:function(a){var b=a.parentNode;return b&&b.parentNode&&b.parentNode.selectedIndex,null},set:function(a){var b=a.parentNode;b&&(b.selectedIndex,b.parentNode&&b.parentNode.selectedIndex)}}),r.each(["tabIndex","readOnly","maxLength","cellSpacing","cellPadding","rowSpan","colSpan","useMap","frameBorder","contentEditable"],function(){r.propFix[this.toLowerCase()]=this});var _a=/[\t\r\n\f]/g;function ab(a){return a.getAttribute&&a.getAttribute("class")||""}r.fn.extend({addClass:function(a){var b,c,d,e,f,g,h,i=0;if(r.isFunction(a))return this.each(function(b){r(this).addClass(a.call(this,b,ab(this)))});if("string"==typeof a&&a){b=a.match(K)||[];while(c=this[i++])if(e=ab(c),d=1===c.nodeType&&(" "+e+" ").replace(_a," ")){g=0;while(f=b[g++])d.indexOf(" "+f+" ")<0&&(d+=f+" ");h=r.trim(d),e!==h&&c.setAttribute("class",h)}}return this},removeClass:function(a){var b,c,d,e,f,g,h,i=0;if(r.isFunction(a))return this.each(function(b){r(this).removeClass(a.call(this,b,ab(this)))});if(!arguments.length)return this.attr("class","");if("string"==typeof a&&a){b=a.match(K)||[];while(c=this[i++])if(e=ab(c),d=1===c.nodeType&&(" "+e+" ").replace(_a," ")){g=0;while(f=b[g++])while(d.indexOf(" "+f+" ")>-1)d=d.replace(" "+f+" "," ");h=r.trim(d),e!==h&&c.setAttribute("class",h)}}return this},toggleClass:function(a,b){var c=typeof a;return"boolean"==typeof b&&"string"===c?b?this.addClass(a):this.removeClass(a):r.isFunction(a)?this.each(function(c){r(this).toggleClass(a.call(this,c,ab(this),b),b)}):this.each(function(){var b,d,e,f;if("string"===c){d=0,e=r(this),f=a.match(K)||[];while(b=f[d++])e.hasClass(b)?e.removeClass(b):e.addClass(b)}else void 0!==a&&"boolean"!==c||(b=ab(this),b&&V.set(this,"__className__",b),this.setAttribute&&this.setAttribute("class",b||a===!1?"":V.get(this,"__className__")||""))})},hasClass:function(a){var b,c,d=0;b=" "+a+" ";while(c=this[d++])if(1===c.nodeType&&(" "+ab(c)+" ").replace(_a," ").indexOf(b)>-1)return!0;return!1}});var bb=/\r/g,cb=/[\x20\t\r\n\f]+/g;r.fn.extend({val:function(a){var b,c,d,e=this[0];{if(arguments.length)return d=r.isFunction(a),this.each(function(c){var e;1===this.nodeType&&(e=d?a.call(this,c,r(this).val()):a,null==e?e="":"number"==typeof e?e+="":r.isArray(e)&&(e=r.map(e,function(a){return null==a?"":a+""})),b=r.valHooks[this.type]||r.valHooks[this.nodeName.toLowerCase()],b&&"set"in b&&void 0!==b.set(this,e,"value")||(this.value=e))});if(e)return b=r.valHooks[e.type]||r.valHooks[e.nodeName.toLowerCase()],b&&"get"in b&&void 0!==(c=b.get(e,"value"))?c:(c=e.value,"string"==typeof c?c.replace(bb,""):null==c?"":c)}}}),r.extend({valHooks:{option:{get:function(a){var b=r.find.attr(a,"value");return null!=b?b:r.trim(r.text(a)).replace(cb," ")}},select:{get:function(a){for(var b,c,d=a.options,e=a.selectedIndex,f="select-one"===a.type,g=f?null:[],h=f?e+1:d.length,i=e<0?h:f?e:0;i<h;i++)if(c=d[i],(c.selected||i===e)&&!c.disabled&&(!c.parentNode.disabled||!r.nodeName(c.parentNode,"optgroup"))){if(b=r(c).val(),f)return b;g.push(b)}return g},set:function(a,b){var c,d,e=a.options,f=r.makeArray(b),g=e.length;while(g--)d=e[g],(d.selected=r.inArray(r.valHooks.option.get(d),f)>-1)&&(c=!0);return c||(a.selectedIndex=-1),f}}}}),r.each(["radio","checkbox"],function(){r.valHooks[this]={set:function(a,b){if(r.isArray(b))return a.checked=r.inArray(r(a).val(),b)>-1}},o.checkOn||(r.valHooks[this].get=function(a){return null===a.getAttribute("value")?"on":a.value})});var db=/^(?:focusinfocus|focusoutblur)$/;r.extend(r.event,{trigger:function(b,c,e,f){var g,h,i,j,k,m,n,o=[e||d],p=l.call(b,"type")?b.type:b,q=l.call(b,"namespace")?b.namespace.split("."):[];if(h=i=e=e||d,3!==e.nodeType&&8!==e.nodeType&&!db.test(p+r.event.triggered)&&(p.indexOf(".")>-1&&(q=p.split("."),p=q.shift(),q.sort()),k=p.indexOf(":")<0&&"on"+p,b=b[r.expando]?b:new r.Event(p,"object"==typeof b&&b),b.isTrigger=f?2:3,b.namespace=q.join("."),b.rnamespace=b.namespace?new RegExp("(^|\\.)"+q.join("\\.(?:.*\\.|)")+"(\\.|$)"):null,b.result=void 0,b.target||(b.target=e),c=null==c?[b]:r.makeArray(c,[b]),n=r.event.special[p]||{},f||!n.trigger||n.trigger.apply(e,c)!==!1)){if(!f&&!n.noBubble&&!r.isWindow(e)){for(j=n.delegateType||p,db.test(j+p)||(h=h.parentNode);h;h=h.parentNode)o.push(h),i=h;i===(e.ownerDocument||d)&&o.push(i.defaultView||i.parentWindow||a)}g=0;while((h=o[g++])&&!b.isPropagationStopped())b.type=g>1?j:n.bindType||p,m=(V.get(h,"events")||{})[b.type]&&V.get(h,"handle"),m&&m.apply(h,c),m=k&&h[k],m&&m.apply&&T(h)&&(b.result=m.apply(h,c),b.result===!1&&b.preventDefault());return b.type=p,f||b.isDefaultPrevented()||n._default&&n._default.apply(o.pop(),c)!==!1||!T(e)||k&&r.isFunction(e[p])&&!r.isWindow(e)&&(i=e[k],i&&(e[k]=null),r.event.triggered=p,e[p](),r.event.triggered=void 0,i&&(e[k]=i)),b.result}},simulate:function(a,b,c){var d=r.extend(new r.Event,c,{type:a,isSimulated:!0});r.event.trigger(d,null,b)}}),r.fn.extend({trigger:function(a,b){return this.each(function(){r.event.trigger(a,b,this)})},triggerHandler:function(a,b){var c=this[0];if(c)return r.event.trigger(a,b,c,!0)}}),r.each("blur focus focusin focusout resize scroll click dblclick mousedown mouseup mousemove mouseover mouseout mouseenter mouseleave change select submit keydown keypress keyup contextmenu".split(" "),function(a,b){r.fn[b]=function(a,c){return arguments.length>0?this.on(b,null,a,c):this.trigger(b)}}),r.fn.extend({hover:function(a,b){return this.mouseenter(a).mouseleave(b||a)}}),o.focusin="onfocusin"in a,o.focusin||r.each({focus:"focusin",blur:"focusout"},function(a,b){var c=function(a){r.event.simulate(b,a.target,r.event.fix(a))};r.event.special[b]={setup:function(){var d=this.ownerDocument||this,e=V.access(d,b);e||d.addEventListener(a,c,!0),V.access(d,b,(e||0)+1)},teardown:function(){var d=this.ownerDocument||this,e=V.access(d,b)-1;e?V.access(d,b,e):(d.removeEventListener(a,c,!0),V.remove(d,b))}}});var eb=/\[\]$/,fb=/\r?\n/g,gb=/^(?:submit|button|image|reset|file)$/i,hb=/^(?:input|select|textarea|keygen)/i;function ib(a,b,c,d){var e;if(r.isArray(b))r.each(b,function(b,e){c||eb.test(a)?d(a,e):ib(a+"["+("object"==typeof e&&null!=e?b:"")+"]",e,c,d)});else if(c||"object"!==r.type(b))d(a,b);else for(e in b)ib(a+"["+e+"]",b[e],c,d)}r.param=function(a,b){var c,d=[],e=function(a,b){var c=r.isFunction(b)?b():b;d[d.length]=encodeURIComponent(a)+"="+encodeURIComponent(null==c?"":c)};if(r.isArray(a)||a.jquery&&!r.isPlainObject(a))r.each(a,function(){e(this.name,this.value)});else for(c in a)ib(c,a[c],b,e); return d.join("&")},r.fn.extend({serialize:function(){return r.param(this.serializeArray())},serializeArray:function(){return this.map(function(){var a=r.prop(this,"elements");return a?r.makeArray(a):this}).filter(function(){var a=this.type;return this.name&&!r(this).is(":disabled")&&hb.test(this.nodeName)&&!gb.test(a)&&(this.checked||!ha.test(a))}).map(function(a,b){var c=r(this).val();return null==c?null:r.isArray(c)?r.map(c,function(a){return{name:b.name,value:a.replace(fb,"\r\n")}}):{name:b.name,value:c.replace(fb,"\r\n")}}).get()}}),r.fn.extend({wrapAll:function(a){var b;return this[0]&&(r.isFunction(a)&&(a=a.call(this[0])),b=r(a,this[0].ownerDocument).eq(0).clone(!0),this[0].parentNode&&b.insertBefore(this[0]),b.map(function(){var a=this;while(a.firstElementChild)a=a.firstElementChild;return a}).append(this)),this},wrapInner:function(a){return r.isFunction(a)?this.each(function(b){r(this).wrapInner(a.call(this,b))}):this.each(function(){var b=r(this),c=b.contents();c.length?c.wrapAll(a):b.append(a)})},wrap:function(a){var b=r.isFunction(a);return this.each(function(c){r(this).wrapAll(b?a.call(this,c):a)})},unwrap:function(a){return this.parent(a).not("body").each(function(){r(this).replaceWith(this.childNodes)}),this}}),r.expr.pseudos.hidden=function(a){return!r.expr.pseudos.visible(a)},r.expr.pseudos.visible=function(a){return!!(a.offsetWidth||a.offsetHeight||a.getClientRects().length)},o.createHTMLDocument=function(){var a=d.implementation.createHTMLDocument("").body;return a.innerHTML="<form></form><form></form>",2===a.childNodes.length}(),r.parseHTML=function(a,b,c){if("string"!=typeof a)return[];"boolean"==typeof b&&(c=b,b=!1);var e,f,g;return b||(o.createHTMLDocument?(b=d.implementation.createHTMLDocument(""),e=b.createElement("base"),e.href=d.location.href,b.head.appendChild(e)):b=d),f=B.exec(a),g=!c&&[],f?[b.createElement(f[1])]:(f=oa([a],b,g),g&&g.length&&r(g).remove(),r.merge([],f.childNodes))};function jb(a){return r.isWindow(a)?a:9===a.nodeType&&a.defaultView}r.offset={setOffset:function(a,b,c){var d,e,f,g,h,i,j,k=r.css(a,"position"),l=r(a),m={};"static"===k&&(a.style.position="relative"),h=l.offset(),f=r.css(a,"top"),i=r.css(a,"left"),j=("absolute"===k||"fixed"===k)&&(f+i).indexOf("auto")>-1,j?(d=l.position(),g=d.top,e=d.left):(g=parseFloat(f)||0,e=parseFloat(i)||0),r.isFunction(b)&&(b=b.call(a,c,r.extend({},h))),null!=b.top&&(m.top=b.top-h.top+g),null!=b.left&&(m.left=b.left-h.left+e),"using"in b?b.using.call(a,m):l.css(m)}},r.fn.extend({offset:function(a){if(arguments.length)return void 0===a?this:this.each(function(b){r.offset.setOffset(this,a,b)});var b,c,d,e,f=this[0];if(f)return f.getClientRects().length?(d=f.getBoundingClientRect(),d.width||d.height?(e=f.ownerDocument,c=jb(e),b=e.documentElement,{top:d.top+c.pageYOffset-b.clientTop,left:d.left+c.pageXOffset-b.clientLeft}):d):{top:0,left:0}},position:function(){if(this[0]){var a,b,c=this[0],d={top:0,left:0};return"fixed"===r.css(c,"position")?b=c.getBoundingClientRect():(a=this.offsetParent(),b=this.offset(),r.nodeName(a[0],"html")||(d=a.offset()),d={top:d.top+r.css(a[0],"borderTopWidth",!0),left:d.left+r.css(a[0],"borderLeftWidth",!0)}),{top:b.top-d.top-r.css(c,"marginTop",!0),left:b.left-d.left-r.css(c,"marginLeft",!0)}}},offsetParent:function(){return this.map(function(){var a=this.offsetParent;while(a&&"static"===r.css(a,"position"))a=a.offsetParent;return a||pa})}}),r.each({scrollLeft:"pageXOffset",scrollTop:"pageYOffset"},function(a,b){var c="pageYOffset"===b;r.fn[a]=function(d){return S(this,function(a,d,e){var f=jb(a);return void 0===e?f?f[b]:a[d]:void(f?f.scrollTo(c?f.pageXOffset:e,c?e:f.pageYOffset):a[d]=e)},a,d,arguments.length)}}),r.each(["top","left"],function(a,b){r.cssHooks[b]=Na(o.pixelPosition,function(a,c){if(c)return c=Ma(a,b),Ka.test(c)?r(a).position()[b]+"px":c})}),r.each({Height:"height",Width:"width"},function(a,b){r.each({padding:"inner"+a,content:b,"":"outer"+a},function(c,d){r.fn[d]=function(e,f){var g=arguments.length&&(c||"boolean"!=typeof e),h=c||(e===!0||f===!0?"margin":"border");return S(this,function(b,c,e){var f;return r.isWindow(b)?0===d.indexOf("outer")?b["inner"+a]:b.document.documentElement["client"+a]:9===b.nodeType?(f=b.documentElement,Math.max(b.body["scroll"+a],f["scroll"+a],b.body["offset"+a],f["offset"+a],f["client"+a])):void 0===e?r.css(b,c,h):r.style(b,c,e,h)},b,g?e:void 0,g)}})}),"function"==typeof define&&define.amd&&define("jquery",[],function(){return r});var kb=a.jQuery,lb=a.$;return r.noConflict=function(b){return a.$===r&&(a.$=lb),b&&a.jQuery===r&&(a.jQuery=kb),r},b||(a.jQuery=a.$=r),r}); |
Added utils/load-the-db.scm version [92b9fb2b93].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;; start the repl and then load this file (define start-time (current-seconds)) (let loop ((last-print 0) (num-calls 0)) (let* ((all-run-ids (rmt:get-all-run-ids)) (do-print (> (- (current-seconds) last-print) 2)) (max-query 0) (num-calls (+ num-calls 1 ;; account for call above (length all-run-ids) ;; account for the get-tests-for-run in the for-each below ))) (for-each (lambda (run-id) ;; (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) (let* ((all-run-data (rmt:get-tests-for-run run-id "%" '() '() #f #f #f #f #f #f #f #f))) (set! num-calls (+ num-calls (length all-run-data))) (for-each (lambda (testdat) (let* ((test-id (vector-ref testdat 0)) (start-at (current-milliseconds)) (testinfo (rmt:get-test-info-by-id run-id test-id)) (query-time (- (current-milliseconds) start-at))) (if (> query-time max-query) (set! max-query query-time)))) all-run-data) (if do-print (let* ((run-time (- (current-seconds) start-time)) (qry-rate (if (> run-time 0) (inexact->exact (round (/ num-calls run-time))) -1))) (print "Running "run-time"s, run "run-id " has "(length all-run-data)" tests, max query "max-query "ms with avg query rate "qry-rate" qry/s"))))) all-run-ids) (loop (if do-print (current-seconds) last-print) num-calls))) |
Modified utils/mk_wrapper from [713ec8f660] to [4fc79e58e7].
︙ | ︙ | |||
42 43 44 45 46 47 48 49 50 51 52 53 54 55 | if [ "\$LD_LIBRARY_PATH" != "" ];then export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:\$LD_LIBRARY_PATH:$libdir else export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:$libdir fi export MT_SQLITE3_EXE=$sqlite3_exe __EOF ) > $cfgfile echo else echo "INFO: LD_LIBRARY_PATH not set" >&2 fi | > > > > > > > > > | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 | if [ "\$LD_LIBRARY_PATH" != "" ];then export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:\$LD_LIBRARY_PATH:$libdir else export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:$libdir fi export MT_SQLITE3_EXE=$sqlite3_exe http_vars="http_proxy https_proxy HTTP_PROXY HTTPS_PROXY" for i in \$http_vars do j=\${!i} if [ "\$j" != "" ]; then unset \$i fi done __EOF ) > $cfgfile echo else echo "INFO: LD_LIBRARY_PATH not set" >&2 fi |
︙ | ︙ | |||
91 92 93 94 95 96 97 | if [[ \$(ulimit -a | grep 'open files' | awk '{print \$4}') -gt 10000 ]];then ulimit -n 10000;fi EOF # echo "#!/bin/bash" > $target # echo "exec $prefix/bin/.\$(lsb_release -sr)/$cmd \"\$@\"" >> $target echo "lsbr=\$(lsb_release -sr)" >> $target | < | < | 100 101 102 103 104 105 106 107 108 109 110 | if [[ \$(ulimit -a | grep 'open files' | awk '{print \$4}') -gt 10000 ]];then ulimit -n 10000;fi EOF # echo "#!/bin/bash" > $target # echo "exec $prefix/bin/.\$(lsb_release -sr)/$cmd \"\$@\"" >> $target echo "lsbr=\$(lsb_release -sr)" >> $target echo "source $prefix/bin/.\$lsbr/cfg.sh" >> $target # echo "if [[ -e \$lsbr ]];then source \$lsbr;fi" >> $target echo "exec $prefix/bin/.\$lsbr/$cmd \"\$@\"" >> $target |
Added utils/mt-new-to-old.scm version [34ae67e282].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (module mt-new-to-old * (import scheme chicken.file chicken.base chicken.string chicken.pretty-print sqlite3) (if (not (file-exists? ".megatest/main.db")) (begin (print "No .megatest/main.db found, exiting") (exit 1))) (copy-file ".megatest/main.db" "megatest.db" #t) (define tests_fields "run_id,testname,host,cpuload,diskfree,uname,rundir,shortdir,item_path,state,status,attemptnum,final_logf,logdat,run_duration,comment,event_time,fail_count,pass_count,archived") (define extra_fields "testname,item_path") (define (import-one dbfile destdb) (print "Importing "dbfile) (let* ((db (open-database dbfile)) (rows (fold-row (lambda (res . row) (cons row res)) '() db (conc "SELECT "extra_fields","tests_fields" FROM tests;")))) (finalize! db) (print "Found "(length rows)" records to insert.") (for-each (lambda (row) (let* ((testname (car row)) (itempath (cadr row)) (remrow (cddr row)) (run-id (car remrow)) (ready-row (string-intersperse (map (lambda (x) (if (number? x) (conc x) (conc "'"x"'"))) remrow) ","))) (print run-id","testname"/"itempath) (execute destdb "DELETE FROM tests WHERE testname=? AND item_path=? AND run_id=?;" (or testname "") (or itempath "") (or run-id "")) (apply execute destdb (conc "INSERT INTO tests ("tests_fields") VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);") remrow))) ;; ("ready-row");")))) rows))) (define (process-all) (let* ((outdb (open-database "megatest.db")) (indbs (glob ".megatest/[0-9]*.db"))) (with-transaction outdb (lambda () (for-each (lambda (dbfname) (import-one dbfname outdb)) indbs))) (finalize! outdb))) ) (import mt-new-to-old) (process-all) |
Added utils/mt-new-to-old.sh version [09b9e5e09c].
> > > > > > > > | 1 2 3 4 5 6 7 8 | #!/bin/bash cp .megatest/main.db megatest.db for db in $(ls .megatest/?.db); do echo $db sqlite3 $db "SELECT * FROM tests" | sqlite3 megatest.db ".import /dev/stdin tests" done |
Added utils/mt-old-to-new.sh version [78adcda056].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | #!/bin/bash if [ -d ".megatest" ] then echo ".megatest directory present." echo "You have already migrated. " exit fi mkdir -p .megatest cp megatest.db .megatest/main.db sqlite3 .megatest/main.db << END_SQL delete from tests; delete from test_steps; END_SQL version_id=$(sqlite3 .megatest/main.db "select id from metadat where var = 'MEGATEST_VERSION'") current_version=$(megatest -version) sqlite3 .megatest/main.db "replace into metadat (id,var,val) values($version_id,'MEGATEST_VERSION','$current_version')" sqlite3 megatest.db 'select id from runs' > runs.txt for run in $(cat runs.txt) do echo "working on run id $run" dbnum=$(($run%100)) if [ ! -f ".megatest/$dbnum.db" ] then dbnum=$(($run%100)) cp megatest.db .megatest/$dbnum.db sqlite3 .megatest/$dbnum.db << END_SQL delete from tests where run_id in (select id from runs where id%100!=$dbnum); delete from test_data; delete from test_meta; delete from test_rundat; delete from test_steps where not exists ( select id from tests where tests.id = test_steps.test_id); replace into metadat (id,var,val) values($version_id,'MEGATEST_VERSION','$current_version'); VACUUM; END_SQL fi done |
Modified utils/mt_ezstep from [c3b3a9d270] to [ab5ea4be93].
︙ | ︙ | |||
29 30 31 32 33 34 35 | if [[ "x$1" == "x" ]];then echo "Usage: $usage" exit fi # Since the user may not have . on the path and since we are likely to want to # run test scripts in the current directory add the current dir to the path | | | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | if [[ "x$1" == "x" ]];then echo "Usage: $usage" exit fi # Since the user may not have . on the path and since we are likely to want to # run test scripts in the current directory add the current dir to the path export PATH="$PATH:$PWD" testrundir=$1; shift stepname=$1;shift command=$* allstatus=99 runstatus=99 |
︙ | ︙ |
Modified utils/mt_xterm from [868b69899e] to [27e4db9521].
︙ | ︙ | |||
14 15 16 17 18 19 20 | # 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/>. MT_TMPDISPLAY=$DISPLAY | > > > > | > | > > > > | 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 | # 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/>. MT_TMPDISPLAY=$DISPLAY MT_TMPUSER=$USER MT_HOME=$HOME tmpfile=`mktemp` if [[ -e megatest.sh ]]; then grep -v "export USER=" megatest.sh | grep -v "export HOME=" > $tmpfile source $tmpfile rm $tmpfile fi export DISPLAY=$MT_TMPDISPLAY export USER=$USER export HOME=$MT_HOME if [ x"$MT_XTERM_CMD" == "x" ];then exec xterm "$@" else exec $MT_XTERM_CMD fi |
Modified utils/nbfake from [c26c7b18f9] to [3e514ddfd2].
︙ | ︙ | |||
37 38 39 40 41 42 43 44 45 46 47 48 49 50 | nbfake <command to run> nbfake behavior can be changed by setting the following env vars: NBFAKE_HOST SSH to \$NBFAKE_HOST and run command NBFAKE_LOG Logfile for nbfake output NB_WASH_GROUPS comma-separated list of groups to wash into NB_WASH_ENABLED must be set in order to enable wash groups __EOF exit fi #============================================================================== # Setup | > | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 | nbfake <command to run> nbfake behavior can be changed by setting the following env vars: NBFAKE_HOST SSH to \$NBFAKE_HOST and run command NBFAKE_LOG Logfile for nbfake output NB_WASH_GROUPS comma-separated list of groups to wash into NB_WASH_ENABLED must be set in order to enable wash groups NBFAKE_QUIET set to suppress informational output __EOF exit fi #============================================================================== # Setup |
︙ | ︙ | |||
85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 | WASHCMD="wash -q -n $grouplist -X" fi #============================================================================== # Run and log #============================================================================== cat <<__EOF >&2 #====================================================================== # NBFAKE logging command to: $MY_NBFAKE_LOG # $WASHCMD $* #====================================================================== __EOF if [[ -z "$MY_NBFAKE_HOST" ]]; then # Run locally | > > | | | 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 | WASHCMD="wash -q -n $grouplist -X" fi #============================================================================== # Run and log #============================================================================== if [[ -z "$NBFAKE_QUIET" ]];then cat <<__EOF >&2 #====================================================================== # NBFAKE logging command to: $MY_NBFAKE_LOG # $WASHCMD $* #====================================================================== __EOF fi if [[ -z "$MY_NBFAKE_HOST" ]]; then # Run locally sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=\"$PATH\"; nohup $WASHCMD $* >> $MY_NBFAKE_LOG 2>&1 &" else # run remotely ssh -X -n -f $MY_NBFAKE_HOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=\"$PATH\"; nohup $WASHCMD $* >> $MY_NBFAKE_LOG 2>&1 &\"" fi |
Added utils/open-files.sh version [61001a23e2].
> > > | 1 2 3 | echo "Database opens: $(lsof -c mtest|egrep '.*db$'|wc -l)" echo "Logfile opens: $(lsof -c mtest|egrep '.*log$'|wc -l)" echo "TCP connections: $(lsof -c mtest|grep TCP|wc -l)" |
Modified utils/plot-code.scm from [2b6e0cd992] to [692dd68f5f].
︙ | ︙ | |||
21 22 23 24 25 26 27 | ;; Coming soon (right?) Usage: plot-code file1.scm,file2.scm "fun1,fun2,x*" *.scm > plot.dot ;; Usage: plot-code file1.scm,file2.scm *.scm > plot.dot ;; dot -Tpdf plot.dot > plot.pdf ;; first param is comma separated list of files to include in the map, use - to do all ;; second param is list of regexs for functions to include in the map ;; third param is list of files to scan | | > > > > > > > > | > > | > > > > > > > > > > > | | | | < | 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 | ;; Coming soon (right?) Usage: plot-code file1.scm,file2.scm "fun1,fun2,x*" *.scm > plot.dot ;; Usage: plot-code file1.scm,file2.scm *.scm > plot.dot ;; dot -Tpdf plot.dot > plot.pdf ;; first param is comma separated list of files to include in the map, use - to do all ;; second param is list of regexs for functions to include in the map ;; third param is list of files to scan ;; (use regex srfi-69 srfi-1 srfi-13) (module plot-code * (import scheme chicken.base chicken.port chicken.string chicken.io) (import chicken.process-context) (import regex srfi-1 srfi-69 srfi-13 matchable) (define files #f) (define targs #f) (define function-patt #f) (define targs #f) (match (command-line-arguments) ((targfiles fnrx . scanfiles) (set! targs (string-split-fields "," targfiles #:infix)) (set! function-patt fnrx) (set! files scanfiles)) (else (print "Usage: plot-code file1.scm,file2.scm *.scm > plot.dot dot -Tpdf plot.dot > plot.pdf") (exit))) ;; (define files (cdr (cddddr (argv)))) ;; ;; (let ((targdat (cadddr (argv)))) ;; (if (equal? targdat "-") ;; (set! targs files) ;; (set! targs (string-split targdat ",")))) (define function-rx (regexp function-patt)) (define filedat-defns (make-hash-table)) (define filedat-usages (make-hash-table)) (define defn-rx (regexp "^\\s*\\(define\\s+\\(([^\\s\\)]+).*")) (define all-regexs (make-hash-table)) |
︙ | ︙ | |||
195 196 197 198 199 200 201 | "\"" fnname "\" -> \"" callname "\";")) calls))) function-calls) (print "}") (exit) | > | 215 216 217 218 219 220 221 222 | "\"" fnname "\" -> \"" callname "\";")) calls))) function-calls) (print "}") (exit) ) |
Added utils/plot-uses.scm version [a8d79f928b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | #!/mfs/pkgs/chicken/4.8.0.5/bin/csi -nbq ;; Copyright 2006-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/>. ;; ;; Coming soon (right?) Usage: plot-code file1.scm,file2.scm "fun1,fun2,x*" *.scm > plot.dot ;; Usage: plot-code file1.scm,file2.scm *.scm > plot.dot ;; dot -Tpdf plot.dot > plot.pdf ;; first param is comma separated list of files to include in the map, use - to do all ;; second param is list of regexs for functions to include in the map ;; third param is list of files to scan (module plot-uses * (import scheme chicken) (use regex srfi-69 srfi-13) (use matchable data-structures ports extras) (define unituses-rx (regexp "^\\(declare \\((unit|uses) ([^\\(\\)]+)\\).*")) (define (print-err . data) (with-output-to-port (current-error-port) (lambda () (apply print data)))) (define (process-file ignores fname) (with-input-from-file fname (lambda () (let loop ((modname "DUMMYMOD")) (let* ((inl (read-line))) (if (eof-object? inl) #t (match (string-search unituses-rx inl) ((_ dtype unitname) (if (equal? dtype "unit") (loop unitname) (begin (if (equal? dtype "uses") (if (not (or (member modname '("DUMMYMOD")) (member modname ignores) (member unitname ignores))) (print " \""unitname"\" -> \""modname"\";")) (print-err "ERROR: bad declare line \""inl"\"")) (loop modname)))) (else (loop modname))))))))) (define (main) (match (command-line-arguments) (("todot" ignoreunits . files) (let* ((ignores (string-split ignoreunits ","))) (print-err "Making graph for files: " (string-intersperse files ", ")) (print "digraph uses_unit {") (for-each (lambda (fname) (print "// Filename: "fname) (process-file ignores fname)) files) (print "}"))) (else (print-err "Usage: plot-uses u1,u2... file1.scm ...") (print-err " where u1,u2... are units to ignore and file1.scm... are the files to process.")))) (main) ) ;; ;; ;; Gather the usages ;; (print "digraph G {") ;; (define curr-cluster-num 0) ;; (define function-calls '()) ;; ;; (for-each ;; (lambda (fname) ;; (let ((last-func #f)) ;; (print-err "Processing file " fname) ;; (print "subgraph cluster_" curr-cluster-num " {") ;; (set! curr-cluster-num (+ curr-cluster-num 1)) ;; (with-input-from-file fname ;; (lambda () ;; (with-output-to-port (current-error-port) ;; (lambda () ;; (print "Analyzing file " fname))) ;; (print "label=\"" fname "\";") ;; (let loop ((inl (read-line)) ;; (fnname "toplevel") ;; (allcalls '())) ;; (if (eof-object? inl) ;; (begin ;; (set! function-calls (cons (list fnname allcalls) function-calls)) ;; (for-each ;; (lambda (call-name) ;; (hash-table-set! breadcrumbs call-name #t)) ;; allcalls) ;; (print-err "function: " fnname " allcalls: " allcalls)) ;; (let ((match (string-match defn-rx inl))) ;; (if match ;; (let ((func-name (cadr match))) ;; (if last-func ;; (print "\"" func-name "\" -> \"" last-func "\";") ;; (print "\"" func-name "\";")) ;; (set! last-func func-name) ;; (hash-table-set! breadcrumbs func-name #t) ;; (loop (read-line) ;; func-name ;; allcalls)) ;; (let ((calls (look-for-all-calls inl fnname))) ;; (loop (read-line) fnname (append allcalls calls))))))))) ;; (print "}"))) ;; targs) ;; ;; (print-err "breadcrumbs: " (hash-table-keys breadcrumbs)) ;; (print-err "function-calls: " function-calls) ;; ;; (for-each ;; (lambda (function-call) ;; (print-err "function-call: " function-call) ;; (let ((fnname (car function-call)) ;; (calls (cadr function-call))) ;; (for-each ;; (lambda (callname) ;; (print (if (hash-table-ref/default breadcrumbs callname #f) "" "// ") ;; "\"" fnname "\" -> \"" callname "\";")) ;; calls))) ;; function-calls) ;; ;; (print "}") ;; ;; (exit) ;; |
Modified utils/remrun from [c7d387d56c] to [7a107135c8].
︙ | ︙ | |||
38 39 40 41 42 43 44 | __EOF exit fi export NBFAKE_HOST=$1 shift | < < < < < < | | 38 39 40 41 42 43 44 45 | __EOF exit fi export NBFAKE_HOST=$1 shift exec nbfake $* |
Added utils/setcicd version [5cf60422ad].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 | #!/bin/bash branch=$(fossil branch current) wikiname=${branch}_cicd echo "ready" > $wikiname if fossil wiki export $wikiname;then fossil wiki commit $wikiname $wikiname else fossil wiki create $wikiname $wikiname fi |
Modified utils/whodunit.scm from [4709c0e629] to [dae56f8cd6].
︙ | ︙ | |||
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 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 | ;; 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/>. ;; (use posix srfi-69) (define *numsamples* (or (and (> (length (argv)) 1) (string->number (cadr (argv)))) 3)) (define (topdata) (with-input-from-pipe (conc "top -b -n " *numsamples* " -d 0.1") read-lines)) (define (cleanup-data topdat)list (let loop ((hed (car topdat)) (tal (cdr topdat)) (res '())) (let* ((line-list (string-split hed)) (nums (map (lambda (indat)(or (string->number indat) indat)) line-list)) (not-data (or (null? nums) (not (number? (car nums))))) (new-res (if not-data res (cons nums res)))) (if (null? tal) new-res (loop (car tal)(cdr tal) new-res))))) (print "Getting " *numsamples* " samples of cpu usage data.") (define data (cleanup-data (topdata))) (define pidhash (make-hash-table)) (define userhash (make-hash-table)) ;; sum up and normalize the (for-each (lambda (indat) (let ((pid (car indat)) (usr (cadr indat)) (cpu (list-ref indat 8))) (hash-table-set! userhash usr (+ cpu (hash-table-ref/default userhash usr 0))))) data) (for-each (lambda (usr) (print usr (if (< (string-length usr) 8) "\t\t" "\t") (inexact->exact (round (/ (hash-table-ref userhash usr) *numsamples*))))) (sort (hash-table-keys userhash) (lambda (a b) (> (hash-table-ref userhash a) (hash-table-ref userhash b))))) |
Modified widgets.scm from [dcc875399e] to [3a32b6256a].
︙ | ︙ | |||
12 13 14 15 16 17 18 | ;; 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/>. (require-library srfi-4 iup) | | > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | ;; 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/>. (require-library srfi-4 iup) (import srfi-4 iup ;; iup-pplot iup-glcanvas) ;; iup-web (define (popup dlg . args) (apply show dlg #:modal? 'yes args) (destroy! dlg)) (define (properties ih) (popup (element-properties-dialog ih)) |
︙ | ︙ | |||
130 131 132 133 134 135 136 | (button "dial" action: (lambda (self) (properties (dial "")))) (button "matrix" action: (lambda (self) (properties (matrix)))) (fill) margin: '0x0) (hbox | | | 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 | (button "dial" action: (lambda (self) (properties (dial "")))) (button "matrix" action: (lambda (self) (properties (matrix)))) (fill) margin: '0x0) (hbox #;(button "pplot" action: (lambda (self) (properties (pplot)))) (button "glcanvas" action: (lambda (self) (properties (glcanvas)))) ;; (button "web-browser" ;; action: (lambda (self) (properties (web-browser)))) (fill) margin: '0x0) |
︙ | ︙ |