Overview
Context
Changes
Modified client.scm
from [50265f350f]
to [cbdbeb9ff4].
︙ | | |
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
|
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
|
-
+
-
+
|
run-id
(tasks:hostinfo-get-interface server-dat)
(tasks:hostinfo-get-port server-dat)
" client:setup (server-dat = #t)")
(if (> remaining-tries 8)
(thread-sleep! (+ 1 (random 5))) ;; spread out the starts a little
(thread-sleep! (+ 15 (random 20)))) ;; it isn't going well. give it plenty of time
(server:try-running run-id)
(server:try-running *toppath*)
(thread-sleep! 5) ;; give server a little time to start up
(client:setup run-id remaining-tries: (- remaining-tries 1))
)))
(begin ;; no server registered
(let ((num-available (tasks:num-in-available-state (db:dbdat-get-db tdbdat) run-id)))
(debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries " num-available=" num-available)
(if (< num-available 2)
(server:try-running run-id))
(server:try-running *toppath*))
(thread-sleep! (+ 5 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms.
(client:setup run-id remaining-tries: (- remaining-tries 1)))))))))
;; keep this as a function to ease future
(define (client:start run-id server-info)
(http-transport:client-connect (tasks:hostinfo-get-interface server-info)
(tasks:hostinfo-get-port server-info)))
|
︙ | | |
Modified common.scm
from [d2df0eaa3f]
to [6953f07d9c].
︙ | | |
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
|
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
|
-
+
|
(define *run-info-cache* (make-hash-table)) ;; run info is stable, no need to reget
(define *launch-setup-mutex* (make-mutex)) ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set
(define *homehost-mutex* (make-mutex))
(defstruct remote
(hh-dat (common:get-homehost)) ;; homehost record ( addr . hhflag )
(server-url (if *toppath* (server:read-dotserver *toppath*))) ;; (server:check-if-running *toppath*) #f))
(server-url (if *toppath* (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*) #f))
(last-server-check 0) ;; last time we checked to see if the server was alive
(conndat #f)
(transport *transport-type*)
(server-timeout (or (server:get-timeout) 100))) ;; default to 100 seconds
;; launching and hosts
(defstruct host
|
︙ | | |
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
|
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
|
-
+
|
(this-wd-num (begin (mutex-lock! *wdnum*mutex) (let ((x *wdnum*)) (set! *wdnum* (add1 *wdnum*)) (mutex-unlock! *wdnum*mutex) x)))
)
(debug:print-info 0 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id)" this-wd-num="this-wd-num)
(if (and legacy-sync (not *time-to-exit*))
(let ((dbstruct (db:setup)))
(debug:print-info 0 *default-log-port* "Server running, periodic sync started.")
(let loop ()
(BB> "watchdog loop. pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
;;(BB> "watchdog loop. pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
;; sync for filesystem local db writes
;;
(mutex-lock! *db-multi-sync-mutex*)
(let* ((need-sync (>= *db-last-access* *db-last-sync*)) ;; no sync since last write
(sync-in-progress *db-sync-in-progress*)
(should-sync (and (not *time-to-exit*)
(> (- (current-seconds) *db-last-sync*) 5))) ;; sync every five seconds minimum
|
︙ | | |
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
|
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
|
-
+
+
|
(set! last-time start-time)
(debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*))))))
;; keep going unless time to exit
;;
(if (not *time-to-exit*)
(let delay-loop ((count 0))
(BB> "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
;;(BB> "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
(if (and (not *time-to-exit*)
(< count 4)) ;; was 11, changing to 4.
(begin
(thread-sleep! 1)
(delay-loop (+ count 1))))
(if (not *time-to-exit*) (loop))))
(if (common:low-noise-print 30)
(debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" this-wd-num="this-wd-num)))))))
(define (std-exit-procedure)
(on-exit (lambda () 0))
;;(BB> "std-exit-procedure called; *time-to-exit*="*time-to-exit*)
(let ((no-hurry (if *time-to-exit* ;; hurry up
#f
(begin
(set! *time-to-exit* #t)
#t))))
(debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.")
(if (and no-hurry (debug:debug-mode 18))
|
︙ | | |
675
676
677
678
679
680
681
682
683
684
685
686
687
688
|
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
|
+
|
)
0)
(define (std-signal-handler signum)
;; (signal-mask! signum)
(set! *time-to-exit* #t)
;;(BB> "got signal "signum)
(debug:print-error 0 *default-log-port* "Received signal " signum " exiting promptly")
;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway
(exit))
(set-signal-handler! signal/int std-signal-handler) ;; ^C
(set-signal-handler! signal/term std-signal-handler)
;; (set-signal-handler! signal/stop std-signal-handler) ;; ^Z NO, do NOT handle ^Z!
|
︙ | | |
Modified common_records.scm
from [4d93fb5556]
to [e3400966c5].
︙ | | |
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
|
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
|
+
-
+
|
(lambda ()
(if *logging*
(db:log-event (apply conc params))
(apply print params)
)))))
;; Brandon's debug printer shortcut (indulge me :)
(define *BB-process-starttime* (current-milliseconds))
(define (BB> . in-args)
(let* ((stack (get-call-chain))
(location #f))
(for-each
(lambda (frame)
(let* ((this-loc (vector-ref frame 0))
(this-func (cadr (string-split this-loc " "))))
(if (equal? this-func "BB>")
(set! location this-loc))))
stack)
(let ((dp-args (append (list 0 *default-log-port* location" " ) in-args)))
(let ((dp-args (append (list 0 *default-log-port* (conc location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000)" ") ) in-args)))
(apply debug:print dp-args))))
(define *BBpp_custom_expanders_list* (make-hash-table))
;; register hash tables with BBpp.
|
︙ | | |
Modified dashboard-tests.scm
from [cd363a9628]
to [4046dd1f97].
︙ | | |
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
|
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
|
-
+
|
(setup-env-defaults runconfigf run-id (make-hash-table) keydat environ-patt: keystring))
(make-hash-table))))
(testconfig (begin
;; (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path)
(runs:set-megatest-env-vars run-id inkeyvals: keydat inrunname: runname intarget: keystring testname: testname itempath: item-path) ;; these may be needed by the launching process
(handle-exceptions
exn
(tests:get-testconfig (db:test-get-testname testdat) test-registry #f)
(tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f)
(tests:get-testconfig (db:test-get-testname testdat) test-registry #t))))
(viewlog (lambda (x)
(if (file-exists? logfile)
;(system (conc "firefox " logfile "&"))
(dashboard-tests:run-html-viewer logfile)
(message-window (conc "File " logfile " not found")))))
(view-a-log (lambda (lfile)
|
︙ | | |
Modified db.scm
from [ef59b3d683]
to [33d7fe0a70].
︙ | | |
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
|
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
|
-
-
-
+
+
+
+
+
+
+
+
+
+
+
-
-
-
+
+
+
-
+
+
|
(if (args:get-arg "-server")
(if (configf:get-section *configdat* "ext-sync")
(let* ((dblist (configf:get-section *configdat* "ext-sync"))
(res '())
(cfgdb #f))
(for-each (lambda (dbitem)
(let* ((stringsplit (string-split (cadr dbitem)))
(dbtype (car stringsplit))
(dbpath (cadr stringsplit)))
(set! cfgdb (dbi:open (string->symbol dbtype) (cons (cons 'dbname dbpath) '()) ))
(dbtype (string->symbol (car stringsplit)))
(dbinfo '())
(cred '()))
(for-each
(lambda (x)
(if (not (eqv? (string->symbol x) dbtype))
(let* ((pair (string-split x ":")))
(if (not (eqv? pair '()))
(set! dbinfo (cons (cons (string->symbol (car pair)) (cadr pair)) dbinfo))))))
stringsplit)
(set! cfgdb (dbi:open dbtype dbinfo))
(db:initialize-main-db cfgdb)
(db:initialize-run-id-db cfgdb)
(set! res (cons (cons cfgdb dbpath) res))))
(set! res (cons (cons cfgdb (alist-ref 'host dbinfo)) res))
))
dblist)
(print res)
(dbr:dbstruct-slave-dbs-set! dbstruct res))))
(dbr:dbstruct-slave-dbs-set! dbstruct res)
)))
;; (mutex-unlock! *rundb-mutex*)
(if (and (not dbfexists)
write-access) ;; *db-write-access*) ;; did not have a prior db and do have write access
(begin
(debug:print 0 *default-log-port* "filling db " (db:dbdat-get-path tmpdb) " with data from " (db:dbdat-get-path mtdb))
(db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb refndb tmpdb))
|
︙ | | |
544
545
546
547
548
549
550
551
552
553
554
555
556
557
|
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
|
+
|
;; 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)
(print "Slave-dbs: " slave-dbs)
(set! todb (cons (dbi:convert (db:dbdat-get-db todb)) (db:dbdat-get-path todb)))
(set! fromdb (cons (dbi:convert (db:dbdat-get-db fromdb)) (db:dbdat-get-path fromdb)))
(handle-exceptions
exn
(begin
(debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.")
|
︙ | | |
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
|
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
|
-
+
+
|
(num->field (apply vector (map car fields)))
(full-sel (conc "SELECT " (string-intersperse (map car fields) ",")
" FROM " tablename (if use-last-update ;; apply last-update criteria
(conc " " (car last-update) ">=" (cdr last-update))
"")
";"))
(full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) "
" VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );"))
" VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );"))
(fromdat '())
(fromdats '())
(tabletypes '())
(totrecords 0)
(batch-len (string->number (or (configf:lookup *configdat* "sync" "batchsize") "10")))
(todat (make-hash-table))
(count 0))
;; set up the field->num table
(for-each
|
︙ | | |
646
647
648
649
650
651
652
653
654
655
656
657
658
659
|
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
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(db:dbdat-get-db todb)
full-sel)
;; first pass implementation, just insert all changed rows
(for-each
(lambda (targdb)
(if (eqv? (dbi:db-dbtype (db:dbdat-get-db targdb)) 'pgd)
(let* ((prep ""))
(for-each
(lambda (row)
(set! tabletypes (cons (cons (string->symbol (vector-ref row 1)) (vector-ref row 2)) tabletypes)))
(dbi:pull-metadata (db:dbdat-get-db fromdb) tablename))
(set! prep (string-intersperse (map (lambda (x) (alist-ref (string->symbol (car x)) tabletypes)) fields) ","))
(set! prep (conc "PREPARE full-ins (" prep ") AS INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) VALUES ( "))
(let loop ((i 1))
(set! prep (conc prep "$" i ","))
(if (< i (- num-fields 1))
(loop (+ i 1))
(set! prep (conc prep "$" (+ i 1) ")"))))
(set! full-ins prep)))
(let* ((db (dbi:convert (db:dbdat-get-db targdb)))
(stmth (dbi:prepare db full-ins)))
;; (db:delay-if-busy targdb) ;; NO WAITING
(for-each
(lambda (fromdat-lst)
(dbi:with-transaction
db
|
︙ | | |
Modified http-transport.scm
from [285317a3d3]
to [880b0371c4].
︙ | | |
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
|
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
|
-
+
+
+
-
-
+
+
+
+
-
+
|
(last-access 0)
(server-timeout (server:get-timeout))
(server-going #f))
(let loop ((count 0)
(server-state 'available)
(bad-sync-count 0)
(start-time (current-milliseconds)))
;;(BB> "http-transport: top of loop; count="count" server-state="server-state" bad-sync-count="bad-sync-count" server-going="server-going)
;; Use this opportunity to sync the tmp db to megatest.db
(if (not server-going) ;; *dbstruct-db*
;; Removed code is pasted below (keeping it around until we are clear it is not needed).
;; no *dbstruct-db* yet, set running after our first pass through and start the db
(if (eq? server-state 'available)
(let ((new-server-id (tasks:server-am-i-the-server? (db:delay-if-busy tdbdat) run-id))) ;; try to ensure no double registering of servers
(if (equal? new-server-id server-id)
(begin
(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep")
;;(BB> "http-transport: ->dbprep")
(thread-sleep! 0.5) ;; give some margin for queries to complete before switching from file based access to server based access
(set! *dbstruct-db* (db:setup)) ;; run-id))
(set! server-going #t)
(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running")
;;(BB> "http-transport: ->running")
(server:write-dotserver *toppath* (conc iface ":" port))
(delete-file* (conc *toppath* "/.starting-server")))
(server:write-dotserver *toppath* iface port (current-process-id) 'http)
(thread-start! *watchdog*)
(server:complete-attempt *toppath*))
(begin ;; gotta exit nicely
;;(BB> "http-transport: ->collision")
(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "collision")
(http-transport:server-shutdown server-id port))))))
;; when things go wrong we don't want to be doing the various queries too often
;; so we strive to run this stuff only every four seconds or so.
(let* ((sync-time (- (current-milliseconds) start-time))
(rem-time (quotient (- 4000 sync-time) 1000)))
(if (and (<= rem-time 4)
(> rem-time 0))
(thread-sleep! rem-time)))
|
︙ | | |
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
|
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
|
-
+
+
+
+
+
+
-
+
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(mutex-unlock! *heartbeat-mutex*)
(if (or (not (equal? sdat (list iface port)))
(not server-id))
(begin
(debug:print-info 0 *default-log-port* "interface changed, refreshing iface and port info")
(set! iface (car sdat))
(set! port (cadr sdat))))
(set! port (cadr sdat))
(server:write-dotserver *toppath* iface port (current-process-id) 'http)))
;; Transfer *db-last-access* to last-access to use in checking that we are still alive
(mutex-lock! *heartbeat-mutex*)
(set! last-access *db-last-access*)
(mutex-unlock! *heartbeat-mutex*)
;; (debug:print 11 *default-log-port* "last-access=" last-access ", server-timeout=" server-timeout)
;;
;; no_traffic, no running tests, if server 0, no running servers
;;
;; (let ((wait-on-running (configf:lookup *configdat* "server" b"wait-on-running"))) ;; wait on running tasks (if not true then exit on time out)
;;
(let* ((hrs-since-start (/ (- (current-seconds) server-start-time) 3600))
(adjusted-timeout (if (> hrs-since-start 1)
(- server-timeout (inexact->exact (round (* hrs-since-start 60)))) ;; subtract 60 seconds per hour
server-timeout)))
(if (common:low-noise-print 120 "server timeout")
(debug:print-info 0 *default-log-port* "Adjusted server timeout: " adjusted-timeout))
(cond
((not (server:confirm-dotserver *toppath* iface port (current-process-id) 'http))
(debug:print-info 0 *default-log-port* "Server .server file does not exist or contents do not match. Initiate server shutdown.")
(http-transport:server-shutdown server-id port))
(if (and *server-run*
((and *server-run*
(> (+ last-access server-timeout)
(current-seconds)))
(begin
(if (common:low-noise-print 120 "server continuing")
(debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access)))
;;
;; Consider implementing some smarts here to re-insert the record or kill self is
;; the db indicates so
;;
;; (if (tasks:server-am-i-the-server? tdb run-id)
;; (tasks:server-set-state! tdb server-id "running"))
;;
(loop 0 server-state bad-sync-count (current-milliseconds)))
(http-transport:server-shutdown server-id port))))))
(if (common:low-noise-print 120 "server continuing")
(debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access)))
;;
;; Consider implementing some smarts here to re-insert the record or kill self is
;; the db indicates so
;;
;; (if (tasks:server-am-i-the-server? tdb run-id)
;; (tasks:server-set-state! tdb server-id "running"))
;;
(loop 0 server-state bad-sync-count (current-milliseconds)))
(else
(debug:print-info 0 *default-log-port* "Server timeed out. seconds since last db access: " (- (current-seconds) last-access))
(http-transport:server-shutdown server-id port)))))))
;; code cut out from above
;;
;; (condition-case
;; ;; (if (and (member (mutex-state *db-sync-mutex*) '(abandoned not-abandoned))
;; ;; (> (- (current-seconds) *db-last-sync*) 5)) ;; if not currently being synced nor recently synced
;; (db:sync-touched *dbstruct-db* *run-id* force-sync: #t) ;; usually done in the watchdog, not here.
|
︙ | | |
484
485
486
487
488
489
490
491
492
493
494
495
496
497
|
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
|
+
|
;; (if (and (<= rem-time 4)
;; (> rem-time 0))
;; (thread-sleep! rem-time)
;; (thread-sleep! 4))) ;; fallback for if the math is changed ...
(define (http-transport:server-shutdown server-id port)
(let ((tdbdat (tasks:open-db)))
;;(BB> "http-transport:server-shutdown called")
(debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id))
;;
;; start_shutdown
;;
(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down")
(set! *time-to-exit* #t) ;; tell on-exit to be fast as we've already cleaned up
(portlogger:open-run-close portlogger:set-port port "released")
|
︙ | | |
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
|
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
|
+
-
-
+
-
-
-
+
-
+
|
(/ *total-non-write-delay*
*number-non-write-queries*))
" ms")
(debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
(tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running complete")
;; if the .server file contained :myport then we can remove it
(server:remove-dotserver-file *toppath* port)
;;(BB> "http-transport:server-shutdown -> exit")
(exit)))
;; all routes though here end in exit ...
;;
;; start_server?
;;
(define (http-transport:launch run-id)
(with-output-to-file
(conc *toppath* "/.starting-server")
(server:attempting-start *toppath*)
(lambda ()
(print (current-process-id) " on " (get-host-name))))
(let* ((tdbdat (tasks:open-db)))
(set! *run-id* run-id)
(if (args:get-arg "-daemonize")
(begin
(daemon:ize)
(if *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it
(begin
(current-error-port *alt-log-file*)
(current-output-port *alt-log-file*)))))
(if (and (server:read-dotserver *toppath*)
(server:check-if-running run-id))
(begin
(debug:print 0 *default-log-port* "INFO: Server for run-id " run-id " already running")
(exit 0))
(begin ;; ok, no server detected, clean out any lingering records
(tasks:server-force-clean-running-records-for-run-id (db:delay-if-busy tdbdat) run-id "notresponding")))
(tasks:server-force-clean-running-records-for-run-id (db:delay-if-busy tdbdat) run-id "notresponding")))
(let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id))
(remtries 4))
(if (not server-id)
(if (> remtries 0)
(begin
(thread-sleep! 2)
(loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)
(- remtries 1)))
(begin
;; since we didn't get the server lock we are going to clean up and bail out
(debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
(tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch")
(delete-file* (conc *toppath* "/.starting-server"))
(server:complete-attempt *toppath*)
))
(let* ((th2 (make-thread (lambda ()
(debug:print-info 0 *default-log-port* "Server run thread started")
(http-transport:run
(if (args:get-arg "-server")
(args:get-arg "-server")
"-")
|
︙ | | |
Modified launch.scm
from [e1f9f3deb0]
to [580823485a].
︙ | | |
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
|
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
|
-
+
|
)))))
;; then, if runscript ran ok (or did not get called)
;; do all the ezsteps (if any)
(if ezsteps
(let* ((testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here?
;; NOTE: it is tempting to turn off force-create of testconfig but dynamic
;; ezstep names need a full re-eval here.
(tests:get-testconfig test-name tconfigreg #t force-create: #t)) ;; 'return-procs)))
(tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs)))
(ezstepslst (if (hash-table? testconfig)
(hash-table-ref/default testconfig "ezsteps" '())
#f)))
(if testconfig
(hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ...
(begin
(launch:setup)
|
︙ | | |
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
|
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
|
-
+
|
(list "MT_TEST_NAME" test-name)
(list "MT_RUNNAME" runname)
(list "MT_ITEMPATH" item-path)
)
itemdat))
(let* ((tregistry (tests:get-all)) ;; third param (below) is system-allowed
;; for tconfig, why do we allow fallback to test-conf?
(tconfig (or (tests:get-testconfig test-name tregistry #t force-create: #t)
(tconfig (or (tests:get-testconfig test-name item-path tregistry #t force-create: #t)
(begin
(debug:print 0 *default-log-port* "WARNING: falling back to pre-calculated testconfig. This is likely not desired.")
test-conf))) ;; force re-read now that all vars are set
(useshell (let ((ush (config-lookup *configdat* "jobtools" "useshell")))
(if ush
(if (equal? ush "no") ;; must use "no" to NOT use shell
#f
|
︙ | | |
Modified megatest-version.scm
from [0bf6986bb1]
to [2c08f91447].
1
2
3
4
5
6
7
|
1
2
3
4
5
6
7
|
-
+
|
;; Always use two or four digit decimal
;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..
(declare (unit megatest-version))
(define megatest-version 1.6302)
(define megatest-version 1.6303)
|
Modified megatest.scm
from [e7342b90ae]
to [ba3fdf979e].
︙ | | |
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
|
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
|
+
-
-
+
+
+
|
(let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
(if targ (setenv "MT_TARGET" targ)))
;; The watchdog is to keep an eye on things like db sync etc.
;;
(define *watchdog* (make-thread common:watchdog "Watchdog thread"))
(if (not (args:get-arg "-server"))
(thread-start! *watchdog*)
;; (BB> "thread-start! watchdog")
(thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog
;;(BB> "thread-start! watchdog")
(if (args:get-arg "-log")
(let ((oup (open-output-file (args:get-arg "-log"))))
(debug:print-info 0 *default-log-port* "Sending log output to " (args:get-arg "-log"))
(set! *default-log-port* oup)))
(if (or (args:get-arg "-h")
(args:get-arg "-help")
|
︙ | | |
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
|
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
|
-
-
+
+
+
+
+
+
+
+
+
|
;;======================================================================
;; Exit and clean up
;;======================================================================
(if (not *didsomething*)
(debug:print 0 *default-log-port* help))
(BB> "thread-join! watchdog")
(thread-join! *watchdog*)
;;(BB> "thread-join! watchdog")
;; join the watchdog thread if it has been thread-start!ed (it may not have been started in the case of a server that never enters running state)
;; (symbols returned by thread-state: created ready running blocked suspended sleeping terminated dead)
(if (thread? *watchdog*)
(case (thread-state *watchdog*)
((ready running blocked sleeping terminated dead)
(thread-join! *watchdog*))))
(set! *time-to-exit* #t)
(if (not (eq? *globalexitstatus* 0))
(if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall"))
(begin
(debug:print 0 *default-log-port* "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*)
(exit 0))
(case *globalexitstatus*
((0)(exit 0))
((1)(exit 1))
((2)(exit 2))
(else (exit 3)))))
|
Added minimal/manyservers.sh version [1fde698cb9].