Changes In Branch v1.80-tcp-inmem Through [24ddf5d235] Excluding Merge-Ins
This is equivalent to a diff from 34c5263e66 to 24ddf5d235
2023-02-22
| ||
11:12 | Merged tcp-inmem check-in: 47a4f89869 user: mrwellan tags: v1.80 | |
2023-02-15
| ||
19:57 | wip check-in: 3528bbcf9e user: matt tags: v1.80-tcp-inmem | |
19:28 | wip. compiles. check-in: 24ddf5d235 user: matt tags: v1.80-tcp-inmem | |
19:21 | wip. compiles. check-in: 4c52a47431 user: matt tags: v1.80-tcp-inmem | |
2023-02-12
| ||
10:52 | wip - start tcp/inmem check-in: 1a2eb25cb6 user: matt tags: v1.80-tcp-inmem | |
2023-02-10
| ||
21:22 | rebased v1.80-debugprint forward check-in: 9d2772b077 user: matt tags: v1.80-debugprint | |
21:16 | Merge v1.80-cleanup as it passed QA check-in: 34c5263e66 user: matt tags: v1.80 | |
21:06 | Merging pretty good branch v1.80-dbperf to v1.80 check-in: 7170e5f43b user: matt tags: v1.80 | |
2023-02-05
| ||
11:47 | Minor clean up. There were a couple communication errors in sixtyfivek but they looked likely to be host related. Closed-Leaf check-in: e973b1fb77 user: matt tags: v1.80-cleanup | |
Modified Makefile from [2a2c13125c] to [fbcf5a6a57].
︙ | ︙ | |||
26 27 28 29 30 31 32 | process.scm runs.scm tasks.scm tests.scm genexample.scm \ http-transport.scm tdb.scm client.scm mt.scm \ ezsteps.scm lock-queue.scm rmt.scm api.scm \ subrun.scm portlogger.scm archive.scm env.scm \ diff-report.scm cgisetup/models/pgdb.scm # module source files | | > > > > > > | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | process.scm runs.scm tasks.scm tests.scm genexample.scm \ http-transport.scm tdb.scm client.scm mt.scm \ ezsteps.scm lock-queue.scm rmt.scm api.scm \ subrun.scm portlogger.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 \ dbmemmod.scm tcp-transportmod.scm all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut tcmt transport-mode.scm : transport-mode.scm.template cp transport-mode.scm.template transport-mode.scm megatest.scm : transport-mode.scm # dbmod.import.o is just a hack here mofiles/dbfile.o : mofiles/debugprint.o mofiles/commonmod.o dbmod.import.o db.o : dbmod.import.o mofiles/debugprint.o : mofiles/mtargs.o # ftail.scm rmtmod.scm commonmod.scm removed |
︙ | ︙ |
Modified client.scm from [6913337164] to [732bd78865].
︙ | ︙ | |||
102 103 104 105 106 107 108 | (match server-dat ((host port start-time server-id pid) (debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) (if (not runremote) (begin ;; Here we are creating a runremote where there was none or it was clobbered with #f ;; | | | 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 | (match server-dat ((host port start-time server-id pid) (debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) (if (not runremote) (begin ;; Here we are creating a runremote where there was none or it was clobbered with #f ;; (set! runremote (make-and-init-remote)) (let* ((server-info (server:check-if-running areapath))) (remote-server-info-set! runremote server-info) (if server-info (begin (remote-server-url-set! runremote (server:record->url server-info)) (remote-server-id-set! runremote (server:record->id server-info))))))) ;; at this point we have a runremote |
︙ | ︙ |
Modified common.scm from [fd6e725fd9] to [9cf1db18d8].
︙ | ︙ | |||
996 997 998 999 1000 1001 1002 | (create-directory dbarea))) dbpath)) #f))) (define (common:get-area-path-signature) (message-digest-string (md5-primitive) *toppath*)) | < < < < < < | 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 | (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 |
︙ | ︙ | |||
2651 2652 2653 2654 2655 2656 2657 | (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_.*"))))) | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 | (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") |
︙ | ︙ |
Modified commonmod.scm from [2570fcf4eb] to [35092db3d2].
︙ | ︙ | |||
21 22 23 24 25 26 27 | (declare (unit commonmod)) (use srfi-69) (module commonmod * | | > > | > > | > > | > > > | > > > > | 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 | (declare (unit commonmod)) (use srfi-69) (module commonmod * (import scheme chicken (prefix sqlite3 sqlite3:) data-structures extras files matchable md5 message-digest posix regex regex-case srfi-1 srfi-18 srfi-69 typed-records ) ;;====================================================================== ;; CONTENTS ;; ;; config file utils ;; misc conversion, data manipulation functions ;; testsuite and area utilites |
︙ | ︙ | |||
206 207 208 209 210 211 212 213 214 215 216 217 | ;; (define (get-cfg-areas cfgdat) (let ((adat (get-section cfgdat "areas"))) (map (lambda (entry) `(,(car entry) . ,(val->alist (cadr entry)))) adat))) ;;====================================================================== ;; misc stuff ;;====================================================================== | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | > | > | > > > > > > | | > > > > | 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 | ;; (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 #f)))))))))) 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)))) ) |
Modified db.scm from [9c05d0ba74] to [42d13b3d83].
︙ | ︙ | |||
581 582 583 584 585 586 587 | ;; 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) | < | | 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 | ;; 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 dbstruct (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)))) |
︙ | ︙ |
Modified dbfile.scm from [e35890c342] to [575621e170].
︙ | ︙ | |||
54 55 56 57 58 59 60 61 62 63 64 65 66 67 | ;; (defstruct dbr:dbstruct (areapath #f) (homehost #f) (tmppath #f) (read-only #f) (subdbs (make-hash-table)) ) ;; NOTE: Need one dbr:subdb per main.db, 1.db ... ;; (defstruct dbr:subdb (dbname #f) ;; .megatest/1.db (mtdbfile #f) ;; mtrah/.megatest/1.db | > > > > > | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 | ;; (defstruct dbr:dbstruct (areapath #f) (homehost #f) (tmppath #f) (read-only #f) (subdbs (make-hash-table)) ;; for the inmem approach (see dbmod.scm) ;; this is one db per server (inmem #f) ;; handle for the in memory copy (dbfile #f) ;; path to the db file on disk (ondiskdb #f) ;; handle for the on-disk file ) ;; NOTE: Need one dbr:subdb per main.db, 1.db ... ;; (defstruct dbr:subdb (dbname #f) ;; .megatest/1.db (mtdbfile #f) ;; mtrah/.megatest/1.db |
︙ | ︙ |
Added dbmemmod.scm version [44a9b812e0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;;====================================================================== ;; 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 dbmemmod)) ;; (declare (uses debugprint)) (declare (uses commonmod)) (module dbmemmod * (import scheme chicken data-structures extras matchable) (import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-1 srfi-69 stack files ports commonmod ;; debugprint ) (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 .megatest ;;====================================================================== ;; 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)) ) ;; NOTE: Need one dbr:subdb per main.db, 1.db ... ;; (defstruct dbr:subdb (dbname #f) ;; .megatest/1.db (mtdbfile #f) ;; mtrah/.megatest/1.db (mtdbdat #f) ;; only need one of these for syncing ;; (dbdats (make-hash-table)) ;; id => dbdat (tmpdbfile #f) ;; /tmp/.../.megatest/1.db ;; (refndbfile #f) ;; /tmp/.../.megatest/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))) (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: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 ) ) ;; ;; set up a single db (e.g. main.db, 1.db ... etc.) ;; ;; ;; (define (db:setup-db dbstruct areapath run-id) ;; (let* ((dbname (db:run-id->dbname run-id)) ;; (dbstruct (hash-table-ref/default dbstructs dbname #f))) ;; (if dbstruct ;; dbstruct ;; (let* ((dbstruct-new (make-dbr:dbstruct))) ;; (db:open-db dbstruct-new run-id areapath: areapath do-sync: #t) ;; (hash-table-set! dbstructs dbname dbstruct-new) ;; dbstruct-new)))) ;; ; Returns the dbdat for a particular dbfile inside the area ;; ;; ;; (define (dbr:dbstruct-get-dbdat dbstruct dbfile) ;; (hash-table-ref/default (dbr:dbstruct-dbdats dbstruct) dbfile #f)) ;; ;; (define (dbr:dbstruct-dbdat-put! dbstruct dbfile db) ;; (hash-table-set! (dbr:dbstruct-dbdats dbstruct) dbfile db)) ;; ;; (define (db:run-id->first-num run-id) ;; (let* ((s (number->string run-id)) ;; (l (string-length s))) ;; (substring s (- l 1) l))) ;; 1234 => 4/1234.db ;; #f => 0/main.db ;; (abandoned the idea of num/db) ;; (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? (else run-id))) ;; POTENTIAL BUG: this implementation could produce a db file if run-id is neither #f or a number (define (dbfile:run-id->dbname run-id) (conc ".megatest/"(dbfile:run-id->dbnum run-id)".db")) ;; 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 do-sync 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))) (set! *dbstruct-dbs* dbstruct) (dbr:dbstruct-areapath-set! dbstruct areapath) (dbr:dbstruct-tmppath-set! dbstruct tmppath) 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 ;; 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 inmem ;; if db not open, open inmem, rundb and sync then return inmem ;; 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 #!optional (tries-left 500)) (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 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 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 (not db-exists)) (init-proc db)) db))) (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 "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))) (define (dbfile:open-no-sync-db dbpath) (if *no-sync-db* *no-sync-db* (begin (if (not (file-exists? dbpath)) (create-directory dbpath #t)) (let* ((dbname (conc dbpath "/no-sync.db")) (db-exists (file-exists? dbname)) (init-proc (lambda (db) (if (not db-exists) (begin (sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));")) ))) (db (dbfile:cautious-open-database dbname init-proc 0 "WAL"))) ;; (sqlite3:open-database dbname))) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") ;; (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) ;; done in cautious-open-database (set! *no-sync-db* db) db)))) (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) (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))) ;; 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 dbstruct 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 dbstruct keys) (let ((keys keys)) ;; (db:get-keys dbstruct))) (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 dbstruct keys) (append (db:sync-main-list dbstruct 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: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;" ))) ;; ;; ADD run-id SUPPORT ;; (define (db:create-all-triggers dbstruct) (db:with-db dbstruct #f #f (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 #f (lambda (dbdat db) (db:drop-triggers db)))) (define (db:is-trigger-dropped db tbl-name) (let* ((trigger-name (if (equal? tbl-name "test_steps") "update_teststeps_trigger" (conc "update_" tbl-name "_trigger"))) (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)) (define no-condition-db-with-db (make-parameter #t)) ;; (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 ;; (define (db: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) (let* ((use-mutex (> *api-process-request-count* 25)) ;; 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)))) (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")) (if (no-condition-db-with-db) (qryproc) (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 (file-exists? fname) (if (> (- (current-seconds) fmod-time) expire-time) (begin (handle-exceptions exn #f (delete-file* fname)) (dbfile:simple-file-lock fname expire-time: expire-time)) #f) (let ((key-string (conc (get-host-name) "-" (current-process-id))) (oup (open-output-file fname))) (with-output-to-port oup (lambda () (print key-string))) (close-output-port oup) #;(with-output-to-file fname ;; bizarre. with-output-to-file does not seem to be cleaning up after itself. (lambda () (print key-string))) (thread-sleep! 0.25) (if (file-exists? fname) (handle-exceptions exn #f (with-input-from-file fname (lambda () (equal? key-string (read-line))))) #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)) (let ((gotlock (dbfile:simple-file-lock-and-wait fname expire-time: expire-time))) (if gotlock (let ((res (proc))) (dbfile:simple-file-release-lock fname) res) (assert #t "FATAL: simple file lock never got a lock.")))) (define (db:get-cache-stmth dbdat db stmt) (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))) (or stmth (let* ((newstmth (sqlite3:prepare db stmt))) ;; (db:hoh-set! stmt-cache db stmt newstmth) (hash-table-set! stmt-cache stmt newstmth) newstmth)))) (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))))) ) |
Modified dbmod.scm from [043beb90c3] to [75595b50f0].
︙ | ︙ | |||
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 * | > > > | > > > > | > | > | > | > > | > > | | | > > > > > < > > > > > > | > > > > > > > > > | | > > > > > > > > > > > | < | > | | > > | < | < > > | 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 | ;; ;; 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 chicken data-structures extras (prefix sqlite3 sqlite3:) posix typed-records 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 run-id) (let* ((areapath (dbr:dbstruct-areapath dbstruct))) (conc areapath"/.megatest"))) (define (dbmod:run-id->full-dbfname dbstruct run-id) (conc (dbmod:get-dbdir dbstruct run-id)"/"(dbmod:run-id->dbfname run-id))) ;;====================================================================== ;; The inmem one-db file per server method goes in here ;;====================================================================== (define (dbmod:open-inmem-db initproc) (let* ((db (sqlite3:open-database ":memory:")) (handler (sqlite3:make-busy-timeout 3600))) (sqlite3:set-busy-handler! db handler) (initproc db) db)) ;; Open the inmem db and the on-disk db ;; populate the inmem db with data ;; ;; Updates fields in dbstruct ;; Returns dbstruct ;; ;; This routine creates the db if not found ;; (define (db:open-dbmoddb dbstruct run-id init-proc) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let* ((dbfname (dbmod:run-id->dbfname run-id)) (dbpath (dbmod:get-dbdir dbstruct run-id)) ;; directory where all the .db files are kept (dbfullname (dbmod:run-id->full-dbfname dbstruct run-id)) (dbexists (file-exists? dbfullname)) (inmem (dbmod:open-inmem-db init-proc)) (write-access (file-write-access? dbpath)) (db (dbfile:with-simple-file-lock (conc dbfullname".lock") (lambda () (let* ((db (sqlite3:open-database dbfullname)) (handler (sqlite3:make-busy-timeout 136000))) (sqlite3:set-busy-handler! db handler) (if write-access (init-proc db)) db))))) (dbr:dbstruct-inmem-set! dbstruct inmem) (dbr:dbstruct-ondiskdb-set! dbstruct db) (dbr:dbstruct-dbfile-set! dbstruct dbfullname) dbstruct)) (define (dbmod:close-db dbstruct) ;; do final sync to disk file ;; (do-sync ...) (sqlite3:finalize! (dbr:dbstruct-ondiskdb dbstruct))) ) |
Modified megatest.scm from [79d9696058] to [bfdf2b502e].
︙ | ︙ | |||
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 | ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) (declare (uses common)) ;; (declare (uses megatest-version)) (declare (uses margs)) (declare (uses runs)) (declare (uses launch)) (declare (uses server)) (declare (uses client)) (declare (uses tests)) (declare (uses genexample)) ;; (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 dbmod)) (declare (uses dbmod.import)) | > > | < | | | > | 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 | ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) (declare (uses common)) ;; (declare (uses megatest-version)) (declare (uses margs)) (declare (uses commonmod)) (declare (uses commonmod.import)) (declare (uses runs)) (declare (uses launch)) (declare (uses server)) (declare (uses client)) (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 dbmod)) (declare (uses dbmod.import)) (declare (uses dbfile)) (declare (uses dbfile.import)) (declare (uses tcp-transport)) ;; (declare (uses debugprint)) ;; (declare (uses debugprint.import)) ;; (declare (uses mtargs)) ;; (declare (uses mtargs.import)) ;; (declare (uses ftail)) ;; (import ftail) (import dbmod commonmod dbfile tcp-transport) (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") |
︙ | ︙ | |||
77 78 79 80 81 82 83 84 85 86 87 88 89 90 | ;; (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 (dbfile:db-init-proc db:initialize-main-db) ;; 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) | > > | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 | ;; (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 (include "transport-mode.scm") (dbfile:db-init-proc db:initialize-main-db) ;; 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) |
︙ | ︙ | |||
583 584 585 586 587 588 589 | ;; 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 | | | < | 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 | ;; 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 (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name (conc tl "/logs/server-" (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) |
︙ | ︙ | |||
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") | > | < > | > > > > > > > > | 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 | ;; 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-number "-run-id")) (tl (launch:setup))) (case (rmt:transport-mode) ((http)(http-transport:launch)) ((tcp) (debug:print 0 *default-log-port* "INFO: Running using tcp method.") (if run-id (tt:start-server tl (dbmod:run-id->dbfname run-id)) (begin (debug:print 0 *default-log-port* "ERROR: transport mode is tcp - -run-id is required.") (exit 1)))) (else (debug:print 0 *default-log-port* "ERROR: rmt:transport-mode value not recognised "(rmt:transport-mode)))) (set! *didsomething* #t))) ;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to ;; a specific Megatest area. Detail are being hashed out and this may change. ;; (if (args:get-arg "-adjutant") (begin |
︙ | ︙ |
Modified mtargs/mtargs.scm from [c1be4192c1] to [9b07b2ae01].
︙ | ︙ | |||
21 22 23 24 25 26 27 | arg-hash get-arg get-arg-from get-args usage print-args any-defined? | | | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 | arg-hash get-arg get-arg-from 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)) |
︙ | ︙ |
Modified rmt.scm from [a2b373e5f1] to [eb5ba03d8d].
︙ | ︙ | |||
20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | (use format typed-records) ;; RADT => purpose of json format?? (declare (unit rmt)) (declare (uses api)) (declare (uses http-transport)) (declare (uses dbfile)) (include "common_records.scm") ;; (declare (uses rmtmod)) (import dbfile) ;; rmtmod) ;; ;; 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 | > > > > > | 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 format typed-records) ;; RADT => purpose of json format?? (declare (unit rmt)) (declare (uses api)) (declare (uses http-transport)) (declare (uses dbfile)) (declare (uses dbmemmod)) (include "common_records.scm") ;; (declare (uses rmtmod)) ;; used by http-transport (import dbfile) ;; rmtmod) (import dbmemmod) (define rmt:transport-mode (make-parameter 'http)) ;; ;; 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 |
︙ | ︙ | |||
59 60 61 62 63 64 65 66 67 68 69 70 71 72 | (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 *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id ;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname)) ;; | > > > > > | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 | (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 ;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname)) ;; |
︙ | ︙ | |||
103 104 105 106 107 108 109 110 111 112 113 114 115 | (let* ((start-time (current-seconds)) ;; snapshot time so all use cases get same value (areapath *toppath*);; TODO - resolve from dbstruct to be compatible with multiple areas (runremote (or area-dat *runremote*)) (attemptnum (+ 1 attemptnum)) (readonly-mode (rmtmod:calc-ro-mode runremote *toppath*))) ;; DOT INIT_RUNREMOTE; // leaving off - doesn't really add to the clarity ;; DOT MUTEXLOCK -> INIT_RUNREMOTE [label="no remote?"]; ;; DOT INIT_RUNREMOTE -> MUTEXLOCK; ;; ensure we have a record for our connection for given area (if (not runremote) ;; can remove this one. should never get here. (begin | > > > > > > > > > > > > > | | < < < | 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 | (let* ((start-time (current-seconds)) ;; snapshot time so all use cases get same value (areapath *toppath*);; TODO - resolve from dbstruct to be compatible with multiple areas (runremote (or area-dat *runremote*)) (attemptnum (+ 1 attemptnum)) (readonly-mode (rmtmod:calc-ro-mode runremote *toppath*))) (case (rmt:transport-mode) ((http)(http-transport-handler runremote cmd rid params attemptnum area-dat areapath readonly-mode)) ((tcp) (tcp-transport-handler runremote cmd rid params attemptnum area-dat areapath readonly-mode))))) (define (tcp-transport-handler runremote cmd rid params attemptnum area-dat areapath readonly-mode) (if (not runremote) (let* ((newremote (make-and-init-remote))) (set! *runremote* newremote) (set! runremote newremote))) (let* ((dbfname (conc (dbfile:run-id->dbnum run-id)".db"))) ;;(dbfile:run-id->path areapath run-id))) (tt:handler runremote cmd rid params attemptnum area-dat areapath readonly-mode dbfname))) (define (http-transport-handler runremote cmd rid params attemptnum area-dat areapath readonly-mode) ;; DOT INIT_RUNREMOTE; // leaving off - doesn't really add to the clarity ;; DOT MUTEXLOCK -> INIT_RUNREMOTE [label="no remote?"]; ;; DOT INIT_RUNREMOTE -> MUTEXLOCK; ;; ensure we have a record for our connection for given area (if (not runremote) ;; can remove this one. should never get here. (begin (set! *runremote* (make-and-init-remote areapath)) (let* ((server-info (remote-server-info *runremote*))) (if server-info (begin (remote-server-url-set! *runremote* (server:record->url server-info)) (remote-server-id-set! *runremote* (server:record->id server-info))))) (set! runremote *runremote*))) ;; new runremote will come from this on next iteration ;; DOT SET_HOMEHOST; // leaving off - doesn't really add to the clarity ;; DOT MUTEXLOCK -> SET_HOMEHOST [label="no homehost?"]; ;; DOT SET_HOMEHOST -> MUTEXLOCK; ;; ensure we have a homehost record (if (or (not (pair? (remote-hh-dat runremote))) ;; not on homehost (not (cdr (remote-hh-dat runremote)))) ;; not on homehost (thread-sleep! 0.1) ;; since we shouldn't get here, delay a little |
︙ | ︙ |
Modified runs.scm from [e0e242ce63] to [9ed9863b9e].
︙ | ︙ | |||
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 | (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) (declare (unit runs)) (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) (declare (uses tests)) (declare (uses server)) (declare (uses mt)) (declare (uses archive)) ;; (declare (uses filedb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") ;; (include "debugger.scm") ;; use this struct to facilitate refactoring ;; (defstruct runs:dat reglen regfull runname max-concurrent-jobs run-id | > > > | 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 | (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) (declare (unit runs)) (declare (uses db)) (declare (uses common)) (declare (uses commonmod)) (declare (uses items)) (declare (uses runconfig)) (declare (uses tests)) (declare (uses server)) (declare (uses mt)) (declare (uses archive)) ;; (declare (uses filedb)) (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) ;; use this struct to facilitate refactoring ;; (defstruct runs:dat reglen regfull runname max-concurrent-jobs run-id |
︙ | ︙ |
Modified server.scm from [1c00c07593] to [5eef4f0a57].
︙ | ︙ | |||
99 100 101 102 103 104 105 | (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*))) | | | | | | | | | | | | | | | | 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 | (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 |
︙ | ︙ | |||
674 675 676 677 678 679 680 | (list (car slst)(string->number (cadr slst))) #f))) (else #f)))) (cond ((and (list? host-port) (eq? (length host-port) 2)) | | | 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 | (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)) |
︙ | ︙ |
Added tcp-transportmod.scm version [4ba3510aa8].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;;====================================================================== ;; 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)) (module tcp-transportmod * (import scheme (prefix sqlite3 sqlite3:) chicken data-structures address-info directory-utils extras files hostinfo matchable md5 message-digest ports posix regex regex-case srfi-1 srfi-18 srfi-4 srfi-69 stack typed-records tcp-server tcp commonmod debugprint ) ;;====================================================================== ;; client ;;====================================================================== ;; (define keep-age-param (make-parameter 10)) ;; qif file age, if over move to attic ;; the client side struct ;; (defstruct tt ;; all (areapath #f) ;; client related (conns (make-hash-table)) ;; dbfname -> conn ) (defstruct tt-conn host port dbfname ) (defstruct tt-srv ;; server related (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) ) (define (tt:make-remote areapath) (make-tt area: areapath)) (define (tt:client-connect-to-server ttdat) #f) ;; client side handler ;; (define (tt:handler runremote cmd rid params attemptnum area-dat areapath readonly-mode dbfname) ;; NOTE: areapath is passed in and in tt struct. We'll use passed in value for now. (let* ((conn (hash-table-ref/default (tt-conns runremote) dbfname #f))) (if conn ;; have connection, call the server (let* ((res (tt:send-receive runremote conn cmd rid params))) (cond ((member res '(busy starting)) (thread-sleep! 1) (tt:handler runremote cmd rid params attemptnum area-dat areapath readonly-mode dbfname)) (else res))) ;; no conn yet, find and or start and find a server (let* ((server (tt:find-server areapath dbfname))) (if server (let* ((conn (tt:client-connect-to-server server))) (hash-table-set! (tt-conns runremote) dbfname conn) (tt:handler runremote cmd rid params attemptnum area-dat areapath readonly-mode dbfname)) ;; no server, try to start one (begin (tt:start-server areapath dbfname) (thread-sleep! 1) (tt:handler runremote cmd rid params attemptnum area-dat areapath readonly-mode dbfname))))))) (define (tt:bid-for-servership run-id) #f) (define (tt:get-current-server run-id) #f) (define (tt:send-receive ttdat conn cmd run-id params) #f) ;;====================================================================== ;; server ;;====================================================================== (define (tt:sync-dbs ttdat) #f) ;; 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 ;; (define (tt:start-server areapath dbfname handler) ;; is there already a server for this dbfile? Then exit. (let* ((ttdat (make-tt-srv areapath: areapath)) (servers (tt:find-server ttdat dbfname))) (tt-srv-handler-set! ttdat handler) (if (null? servers) (begin (tt:start-tcp-server ttdat) ;; start the tcp-server which applies handler to incoming data (tt:keep-running ttdat dbfname)) (begin (debug:print 0 *default-log-port* "INFO: found server(s) already running for db "dbfname", "(string-intersperse servers ",")" Exiting.") (exit))))) ((make-tcp-server (tcp-listen 6504) (lambda () (write-line (seconds->string (current-seconds))))) #t) ;; find a port and start tcp-server ;; (define (tt:start-tcp-server ttdat) (setup-listener ttdat) (let* ((socket (tt-srv-socket ttdat)) (handler (tt-srv-handler ttdat))) ((make-tcp-server socket handler) #t ;; yes, send error messages to std-err ))) (define (tt:keep-running ttdat dbfile) ;; verfiy conn for ready ;; listener socket has been started by this stage (debug:print 0 *default-log-port* "INFO: Got here!!!!")) ;; ;; given an already set up uconn start the cmd-loop ;; ;; ;; (define (tt:cmd-loop ttdat) ;; (let* ((serv-listener (-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))))) ;; ;; ;; ;; (define (wait-and-close uconn) ;; (thread-join! (udat-cmd-thread uconn)) ;; (tcp-close (udat-socket uconn))) ;; ;; (define (tt:shutdown-server ttdat) (let* ((cleanproc (tt-srv-cleanup-proc ttdat))) (if cleanproc (cleanproc)) (tcp-close (tt-srv-socket ttdat)) ;; close up ports here )) ;; (define (wait-and-close uconn) ;; (thread-join! (tt-srv-cmd-thread uconn)) ;; (tcp-close (tt-srv-socket uconn))) ;; 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)) (conn (hash-table-ref/default (tt-conns ttdat) dbfname #f))) (assert conn "FATAL: tt:create-server-registration-file called with no conn, dbfname="dbfname) (let* ((host (tt-conn-host conn)) (port (tt-conn-port conn)) (servinf (conc servdir"/"host":"port"-"(current-process-id)":"dbfname)) (serv-id (tt:mk-signature areapath)) (clean-proc (lambda () (delete-file* servinf)))) (tt-srv-cleanup-proc-set! ttdat clean-proc) (with-output-to-file servinf (lambda () (print "SERVER STARTED: "host":"port" AT "(current-seconds)" server-id: "serv-id" pid: "(current-process-id)" dbfname: "dbfname))) 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 ;; future: ping oldest, if alive remove other :<dbfname> files ;; (define (tt:find-server ttdat dbfname) (let* ((areapath (tt-areapath ttdat)) (servdir (tt:get-servinfo-dir areapath)) (sfiles (glob (conc servdir"/*:"dbfname)))) sfiles)) ;; 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 #!key (profile-mode "")) ;; areapath is *toppath* for a given testsuite area (let* ((logfile (conc areapath "/logs/server.log")) ;; -" curr-pid "-" target-host ".log")) (cmdln (conc mtexe " -server - ";; (or target-host "-") " -m testsuite:" testsuite " " profile-mode ))) ;; (conc " >> " logfile " 2>&1 &"))))) ;; 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 in tcp mode (" cmdln ") ...") (debug:print 0 *default-log-port* "INFO: starting server at " (common:human-time)) (system (conc "nbfake " cmdln)) (pop-directory))) ;;====================================================================== ;; tcp connection stuff ;;====================================================================== ;; 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-srv? uconn) "FATAL: setup-listener called with wrong struct "uconn) (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))) (tt-srv-port-set! uconn port) (tt-srv-host-port-set! uconn (conc addr":"port)) (tt-srv-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))))) ) |
Added transport-mode.scm.template version [936e3f7e57].
> > > | 1 2 3 | ;; 'http or 'tcp ;; (rmt:transport-mode 'tcp) (rmt:transport-mode 'http) |