Megatest

Check-in [51983eb150]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Server now runs
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | inmem-per-run-db
Files: files | file ages | folders
SHA1: 51983eb150f35061906adbc17b7b8c80e5177598
User & Date: matt on 2013-11-24 21:42:18
Other Links: branch diff | manifest | tags
Context
2013-11-24
22:41
Progressing check-in: d5867f23a9 user: matt tags: inmem-per-run-db
21:42
Server now runs check-in: 51983eb150 user: matt tags: inmem-per-run-db
20:16
rundb, inmem and main structures written check-in: b81b7645b9 user: matt tags: inmem-per-run-db
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified db.scm from [7ad6d7a9bd] to [7efe9252ff].

︙︙
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

(declare (uses filedb))

(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")

;; timestamp type (val1 val2 ...)
;; type: meta-info, step
(define *incoming-writes*      '())
(define *completed-writes*   (make-hash-table))
(define *incoming-last-time* (current-seconds))
(define *incoming-mutex*     (make-mutex))
(define *completed-mutex*    (make-mutex))

;; Get/open a database
;;    if run-id => get run specific db
;;    if #f     => get main db
;;    if db already open - return inmem
;;    if db not open, open inmem, rundb and sync then return inmem

;;
(define (db:get-db dbstruct run-id)

  (if run-id
      (db:open-rundb dbstruct run-id)
      (db:open-main dbstruct)))








(define (db:set-sync db)
  (let* ((syncval  (config-lookup *configdat* "setup"     "synchronous"))
	 (val      (cond   ;; 0 | OFF | 1 | NORMAL | 2 | FULL;
		    ((not syncval) #f)
		    ((string->number syncval)
		     (let ((val (string->number syncval)))
		       (if (member val '(0 1 2)) val #f)))
		    ((string-match (regexp "yes" #t) syncval) 1)
		    ((string-match (regexp "no"  #t) syncval) 0)
		    ((string-match (regexp "(off|normal|full)" #t) syncval) syncval)
		    (else 
		     (debug:print 0 "ERROR: synchronous must be 0,1,2,OFF,NORMAL or FULL, you provided: " syncval)
		     #f))))
    (if val


	(begin
	  (debug:print-info 9 "db:set-sync, setting pragma synchronous to " val)
	  (sqlite3:execute db (conc "PRAGMA synchronous = '" val "';"))))))

;;======================================================================
;; K E E P   F I L E D B   I N   dbstruct
;;======================================================================

(define (db:get-filedb dbstruct)
  (let ((db (vector-ref dbstruct 2)))








<
<
<
<
<
|
<






>


>
|
|
|
>
>
>

>
>
>
>
|
<
<
<
<
<
<
<
<
<
|
<
<
|
>
>
|
|
<








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

(declare (uses filedb))

(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")






(define *rundb-mutex* (make-mutex)) ;; prevent problems opening/closing rundb's


;; Get/open a database
;;    if run-id => get run specific db
;;    if #f     => get main db
;;    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 (db:get-db dbstruct run-id)
  (mutex-lock! *rundb-mutex*)
  (let ((db (if run-id
		(db:open-rundb dbstruct run-id)
		(db:open-main dbstruct))))
    ;; db prunning would go here
    (mutex-unlock! *rundb-mutex*)
    db))

;; mod-read:
;;     'mod   modified data
;;     'read  read data
;;
(define (db:done-with dbstruct run-id mod-read)









  (mutex-lock! *rundb-mutex*)


  (if (eq? mod-read 'mod)
      (dbr:dbstruct-set-runvec! dbstruct run-id 'mtime (current-milliseconds))
      (dbr:dbstruct-set-runvec! dbstruct run-id 'rtime (current-milliseconds)))
  (dbr:dbstruct-set-runvec! dbstruct run-id 'inuse #f)
  (mutex-unlock! *rundb-mutex*))


;;======================================================================
;; K E E P   F I L E D B   I N   dbstruct
;;======================================================================

(define (db:get-filedb dbstruct)
  (let ((db (vector-ref dbstruct 2)))
︙︙
117
118
119
120
121
122
123


124
125
126
127
128
129
130

	  (if write-access
	      (begin
		(sqlite3:set-busy-handler! db handler)
		(sqlite3:execute db "PRAGMA synchronous = 0;")))
	  (if (not dbexists)(db:initialize-run-id-db db run-id))
	  (dbr:dbstruct-set-runvec! dbstruct run-id 'rundb db)
	  (dbr:dbstruct-set-runvec! dbstruct run-id 'inmem inmem)


	  inmem))))

;; This routine creates the db. It is only called if the db is not already opened
;;
(define (db:open-main dbstruct) ;;  (conc *toppath* "/megatest.db") (car *configinfo*)))
  (let ((mdb (dbr:dbstruct-get-main dbstruct)))
    (if mdb








>
>








110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125

	  (if write-access
	      (begin
		(sqlite3:set-busy-handler! db handler)
		(sqlite3:execute db "PRAGMA synchronous = 0;")))
	  (if (not dbexists)(db:initialize-run-id-db db run-id))
	  (dbr:dbstruct-set-runvec! dbstruct run-id 'rundb db)
	  (dbr:dbstruct-set-runvec! dbstruct run-id 'inmem inmem)
	  (dbr:dbstruct-set-runvec! dbstruct run-id 'inuse #t)
	  (db:sync-tables db:sync-tests-only db inmem)
	  inmem))))

;; This routine creates the db. It is only called if the db is not already opened
;;
(define (db:open-main dbstruct) ;;  (conc *toppath* "/megatest.db") (car *configinfo*)))
  (let ((mdb (dbr:dbstruct-get-main dbstruct)))
    (if mdb
︙︙
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

		(sqlite3:set-busy-handler! db handler)
		(sqlite3:execute db "PRAGMA synchronous = 0;")))
	  (if (not dbexists)
	      (db:initialize-megatest-db db))
	  (dbr:dbstruct-set-main! dbstruct db)
	  db))))















;; close all opened run-id dbs
(define (db:close-all-db)
  (for-each
   (lambda (db)
     (finalize! db))
   (hash-table-values (vector-ref *open-dbs* 1)))
  (finalize! (vector-ref *open-dbs* 0)))

(define (open-inmem-db)
  (let* ((db      (sqlite3:open-database ":memory:"))
	 (handler   (make-busy-timeout 3600)))
    (db:initialize db)
    (sqlite3:set-busy-handler! db handler)
    (set! sdb:qry (make-sdb:qry)) ;; we open the normalization helpers here
    (set! *fdb*   (filedb:open-db (conc *toppath* "/db/paths.db")))
    db))


;; (define (db:sync-table tblname fields fromdb todb)















































(define (db:tbls db)
  (let ((keys  (db:get-keys db)))
    (list
     (list "keys"
	   '("id"        #f)
	   '("fieldname" #f)
	   '("fieldtype" #f))








>
>
>
>
>
>
>
>
>
>
>
>
>
>

















>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

>
>








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

		(sqlite3:set-busy-handler! db handler)
		(sqlite3:execute db "PRAGMA synchronous = 0;")))
	  (if (not dbexists)
	      (db:initialize-megatest-db db))
	  (dbr:dbstruct-set-main! dbstruct db)
	  db))))

;; sync all touched runs to disk
(define (db:sync-touched dbstruct)
  (for-each
   (lambda (runvec)
     (let ((mtime (vector-ref runvec (dbr:dbstruct-field-name->num 'mtime)))
	   (stime (vector-ref runvec (dbr:dbstruct-field-name->num 'stime)))
	   (rundb (vector-ref runvec (dbr:dbstruct-field-name->num 'rundb)))
	   (inmem (vector-ref runvec (dbr:dbstruct-field-name->num 'inmem))))
       (if (> mtime stime)
	   (begin
	     (db:sync-tables db:sync-tests-only inmem rundb)
	     (vector-set! runvec (dbr:dbstruct-field-name->run 'stime (current-milliseconds)))))))
   (hash-table-values (vector-ref dbstruct 1))))

;; close all opened run-id dbs
(define (db:close-all-db)
  (for-each
   (lambda (db)
     (finalize! db))
   (hash-table-values (vector-ref *open-dbs* 1)))
  (finalize! (vector-ref *open-dbs* 0)))

(define (open-inmem-db)
  (let* ((db      (sqlite3:open-database ":memory:"))
	 (handler   (make-busy-timeout 3600)))
    (db:initialize db)
    (sqlite3:set-busy-handler! db handler)
    (set! sdb:qry (make-sdb:qry)) ;; we open the normalization helpers here
    (set! *fdb*   (filedb:open-db (conc *toppath* "/db/paths.db")))
    db))

;; just tests, test_steps and test_data tables
(define db:sync-tests-only
  (list
   (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))
   (list "test_steps"
	 '("id"             #f)
	 '("test_id"        #f)
	 '("stepname"       #f)
	 '("state"          #f)
	 '("status"         #f)
	 '("event_time"     #f)
	 '("comment"        #f)
	 '("logfile"        #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))))

;; needs db to get keys, this is for syncing all tables
;;
(define (db:tbls db)
  (let ((keys  (db:get-keys db)))
    (list
     (list "keys"
	   '("id"        #f)
	   '("fieldname" #f)
	   '("fieldtype" #f))
︙︙
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349

;; (define open-run-close 
(define open-run-close (if (debug:debug-mode 2)
			   open-run-close-no-exception-handling
			   open-run-close-exception-handling))

(define (db:initialize-megatest-db db)
  (let* ((configdat (car *configinfo*))  ;; tut tut, global warning...
	 (keys     (keys:configq-get-fields configdat))
	 (havekeys (> (length keys) 0))
	 (keystr   (keys->keystr keys))
	 (fieldstr (keys->key/field keys)))
    (for-each (lambda (key)
		(let ((keyn key))
		  (if (member (string-downcase keyn)
			      (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count"








|








391
392
393
394
395
396
397
398
399
400
401
402
403
404
405

;; (define open-run-close 
(define open-run-close (if (debug:debug-mode 2)
			   open-run-close-no-exception-handling
			   open-run-close-exception-handling))

(define (db:initialize-megatest-db db)
  (let* ((configdat (car *configinfo*))  ;; tut tut, global warning...
	 (keys     (keys:config-get-fields configdat))
	 (havekeys (> (length keys) 0))
	 (keystr   (keys->keystr keys))
	 (fieldstr (keys->key/field keys)))
    (for-each (lambda (key)
		(let ((keyn key))
		  (if (member (string-downcase keyn)
			      (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count"
︙︙
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449

                               stepname TEXT, 
                               state TEXT DEFAULT 'NOT_STARTED', 
                               status TEXT DEFAULT 'n/a',
                               event_time TIMESTAMP,
                               comment TEXT DEFAULT '',
                               logfile TEXT DEFAULT '',
                               CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));")
  (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data 
                              (id          INTEGER PRIMARY KEY,
                                     reviewed    TIMESTAMP DEFAULT (strftime('%s','now')),
                                     iterated    TEXT DEFAULT '',
                                     avg_runtime REAL DEFAULT -1,
                                     avg_disk    REAL DEFAULT -1,
                                     tags        TEXT DEFAULT '',
                                     jobgroup    TEXT DEFAULT 'default',
                                CONSTRAINT test_meta_constraint UNIQUE (testname));")
    (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY,
                                test_id INTEGER,
                                category TEXT DEFAULT '',
                                variable TEXT,
	                        value REAL,
	                        expected REAL,
	                        tol REAL,








|
|
|
|
|
|
|
|
|








483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505

                               stepname TEXT, 
                               state TEXT DEFAULT 'NOT_STARTED', 
                               status TEXT DEFAULT 'n/a',
                               event_time TIMESTAMP,
                               comment TEXT DEFAULT '',
                               logfile TEXT DEFAULT '',
                               CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));")
;;   (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data 
;;                               (id          INTEGER PRIMARY KEY,
;;                                      reviewed    TIMESTAMP DEFAULT (strftime('%s','now')),
;;                                      iterated    TEXT DEFAULT '',
;;                                      avg_runtime REAL DEFAULT -1,
;;                                      avg_disk    REAL DEFAULT -1,
;;                                      tags        TEXT DEFAULT '',
;;                                      jobgroup    TEXT DEFAULT 'default',
;;                                 CONSTRAINT test_meta_constraint UNIQUE (testname));")
    (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY,
                                test_id INTEGER,
                                category TEXT DEFAULT '',
                                variable TEXT,
	                        value REAL,
	                        expected REAL,
	                        tol REAL,
︙︙

Modified db_records.scm from [8100f13571] to [76bc6ba447]. 

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

;;======================================================================
;; dbstruct
;;======================================================================

;;
;; -path-|-megatest.db
;;       |-db-|-main.db
;;            |-monitor.db
;;            |-sdb.db
;;            |-fdb.db
;;            |-1.db
;;            |-<N>.db
(define (make-dbr:dbstruct #!key (path #f))
  (make-vector
   #f                  ;; the main db (contains runs, test_meta etc.) NOT CACHED IN MEM
   (make-hash-table)   ;; run-id => [ rundb inmemdb last-mod last-read last-sync ]
   #f                  ;; the global string db (use for state, status etc.)
   path))              ;; path to database files/megatest area

;; get and set main db
(define-inline (dbr:dbstruct-get-main vec)    (vector-ref vec 0))
(define-inline (dbr:dbstruct-set-main! vec db)(vector-set! vec 0 db))

;; get a rundb vector
(define (dbr:dbstruct-get-rundb-rec vec run-id)
  (let* ((dbhash (vector-ref vec 1))
	 (runvec (hash-table-ref/default dbhash run-id)))
    (if runvec
	runvec
	(begin
	  (hash-table-set! dbhash run-id (vector #f #f -1 -1 -1))
	  (dbr:dbstruct-get-rundb-rec vec run-id)))))

;;  [ rundb inmemdb last-mod last-read last-sync ]
(define-inline (dbr:dbstruct-field-name->num field-name)
  (case field-name
    ((rundb) 0) ;; the on-disk db
    ((inmem) 1) ;; the in-memory db
    ((mtime) 2) ;; last modification time
    ((rtime) 3) ;; last read time
    ((stime) 4) ;; last sync time

    (else -1)))

;; get/set rundb fields
(define (dbr:dbstruct-get-runrec vec run-id field-name)
  (let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id)))
    (vector-ref runvec (dbr:dbstruct-field-name->num field-name))))



(define (dbr:dbstruct-set-runvec! vec run-id field-name val)
  (let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id)))
    (vector-set! runvec (dbr:dbstruct-field-name->num field-name) rundb)))

;; get/set inmemdb
(define (dbr:dbstruct-get-inmemdb vec run-id)














|
















|










>




|
|
>
>








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

;;======================================================================
;; dbstruct
;;======================================================================

;;
;; -path-|-megatest.db
;;       |-db-|-main.db
;;            |-monitor.db
;;            |-sdb.db
;;            |-fdb.db
;;            |-1.db
;;            |-<N>.db
(define (make-dbr:dbstruct #!key (path #f))
  (vector
   #f                  ;; the main db (contains runs, test_meta etc.) NOT CACHED IN MEM
   (make-hash-table)   ;; run-id => [ rundb inmemdb last-mod last-read last-sync ]
   #f                  ;; the global string db (use for state, status etc.)
   path))              ;; path to database files/megatest area

;; get and set main db
(define-inline (dbr:dbstruct-get-main vec)    (vector-ref vec 0))
(define-inline (dbr:dbstruct-set-main! vec db)(vector-set! vec 0 db))

;; get a rundb vector
(define (dbr:dbstruct-get-rundb-rec vec run-id)
  (let* ((dbhash (vector-ref vec 1))
	 (runvec (hash-table-ref/default dbhash run-id)))
    (if runvec
	runvec
	(begin
	  (hash-table-set! dbhash run-id (vector #f #f -1 -1 -1 #f))
	  (dbr:dbstruct-get-rundb-rec vec run-id)))))

;;  [ rundb inmemdb last-mod last-read last-sync ]
(define-inline (dbr:dbstruct-field-name->num field-name)
  (case field-name
    ((rundb) 0) ;; the on-disk db
    ((inmem) 1) ;; the in-memory db
    ((mtime) 2) ;; last modification time
    ((rtime) 3) ;; last read time
    ((stime) 4) ;; last sync time
    ((inuse) 5) ;; is the db currently in use
    (else -1)))

;; get/set rundb fields
(define (dbr:dbstruct-get-runrec vec run-id field-name)
  (let ((runvec   (dbr:dbstruct-get-rundb-rec vec run-id))
	(fieldnum (dbr:dbstruct-field-name->num field-name)))
    ;; (vector-set! runvec (dbr:dbstruct-field-name->num 'inuse) #t)
    (vector-ref runvec fieldnum)))

(define (dbr:dbstruct-set-runvec! vec run-id field-name val)
  (let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id)))
    (vector-set! runvec (dbr:dbstruct-field-name->num field-name) rundb)))

;; get/set inmemdb
(define (dbr:dbstruct-get-inmemdb vec run-id)
︙︙

Modified http-transport.scm from [27209e5df0] to [eef5519839].

︙︙
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441

			       (* 3 24 60 60)))))
    (debug:print-info 2 "server-timeout: " server-timeout ", server pid: " spid " on " iface ":" port)
    (let loop ((count 0))
      ;; Use this opportunity to sync the inmemdb to db
      (let ((start-time (current-milliseconds))
	    (sync-time  #f)
	    (rem-time   #f))
	(if *inmemdb* (db:sync-tables (db:tbls *inmemdb*) *inmemdb* *db*)) ;; (db:sync-to *inmemdb* *db*))
	(set! sync-time  (- (current-milliseconds) start-time))
	(debug:print 0 "SYNC: time= " sync-time)
	(set! rem-time (quotient (- 4000 sync-time) 1000))
	(if (and (< rem-time 4)
		 (> rem-time 0))
	    (thread-sleep! rem-time)))









|








427
428
429
430
431
432
433
434
435
436
437
438
439
440
441

			       (* 3 24 60 60)))))
    (debug:print-info 2 "server-timeout: " server-timeout ", server pid: " spid " on " iface ":" port)
    (let loop ((count 0))
      ;; Use this opportunity to sync the inmemdb to db
      (let ((start-time (current-milliseconds))
	    (sync-time  #f)
	    (rem-time   #f))
	(if *inmemdb* (db:sync-touched *inmemdb*))
	(set! sync-time  (- (current-milliseconds) start-time))
	(debug:print 0 "SYNC: time= " sync-time)
	(set! rem-time (quotient (- 4000 sync-time) 1000))
	(if (and (< rem-time 4)
		 (> rem-time 0))
	    (thread-sleep! rem-time)))
︙︙
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486

	  (begin
	    (debug:print-info 0 "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
	    (loop 0))
	  (begin
	    (debug:print-info 0 "Starting to shutdown the server.")
	    ;; need to delete only *my* server entry (future use)
	    (set! *time-to-exit* #t)
	    (if *inmemdb* (db:sync-tables (db:tbls *inmemdb*) *inmemdb* *db*)) ;; (db:sync-to *inmemdb* *db*))
	    (open-run-close tasks:server-deregister-self tasks:open-db (get-host-name))
	    (thread-sleep! 1)
	    (debug:print-info 0 "Max cached queries was    " *max-cache-size*)
	    (debug:print-info 0 "Number of cached writes   " *number-of-writes*)
	    (debug:print-info 0 "Average cached write time "
			      (if (eq? *number-of-writes* 0)
				  "n/a (no writes)"








|








472
473
474
475
476
477
478
479
480
481
482
483
484
485
486

	  (begin
	    (debug:print-info 0 "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
	    (loop 0))
	  (begin
	    (debug:print-info 0 "Starting to shutdown the server.")
	    ;; need to delete only *my* server entry (future use)
	    (set! *time-to-exit* #t)
	    (if *inmemdb* (db:sync-touched *inmemdb*))
	    (open-run-close tasks:server-deregister-self tasks:open-db (get-host-name))
	    (thread-sleep! 1)
	    (debug:print-info 0 "Max cached queries was    " *max-cache-size*)
	    (debug:print-info 0 "Number of cached writes   " *number-of-writes*)
	    (debug:print-info 0 "Average cached write time "
			      (if (eq? *number-of-writes* 0)
				  "n/a (no writes)"
︙︙
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

	(if *toppath* 
	    (let* ((th2 (make-thread (lambda ()
				       (http-transport:run 
					(if (args:get-arg "-server")
					    (args:get-arg "-server")
					    "-"))) "Server run"))
		   (th3 (make-thread http-transport:keep-running "Keep running")))
;;		   (th1 (make-thread server:write-queue-handler  "write queue")))
	      (set! *cache-on* #t)
	      (set! *db*       (open-db))
	      (set! *inmemdb*  (open-in-mem-db))
	      (db:sync-tables (db:tbls *db*) *db* *inmemdb*) ;; (db:sync-to *db* *inmemdb*)

	      (thread-start! th2)
	      (thread-start! th3)
	      ;; (thread-start! th1)
	      (set! *didsomething* #t)
	      (thread-join! th2))
	    (debug:print 0 "ERROR: Failed to setup for megatest")))
    (exit)))

;; (use trace)
;; (trace http-transport:keep-running 
;;        tasks:server-update-heartbeat
;;        tasks:server-get-server-id)
;;        tasks:get-best-server
;;        http-transport:run
;;        http-transport:launch
;;        http-transport:try-start-server
;;        http-transport:client-send-receive
;;        http-transport:make-server-url
;;        tasks:server-register
;;        tasks:server-delete
;;        start-server
;;        hostname->ip
;;        with-input-from-request
;;        tasks:server-deregister-self)

(define (http-transport:server-signal-handler signum)
  (handle-exceptions
   exn
   (debug:print " ... exiting ...")
   (let ((th1 (make-thread (lambda ()
			     (thread-sleep! 1))
			     ;; (if (not *received-response*)
			     ;;	 (receive-message* *runremote*))) ;; flush out last call if applicable
			   "eat response"))
	 (th2 (make-thread (lambda ()
			     (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.")
			     (thread-sleep! 3) ;; give the flush three seconds to do it's stuff
			     (debug:print 0 "       Done.")
			     (exit 4))
			   "exit on ^C timer")))








<
|
<
|
<
<


<





<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






<
<








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

	(if *toppath* 
	    (let* ((th2 (make-thread (lambda ()
				       (http-transport:run 
					(if (args:get-arg "-server")
					    (args:get-arg "-server")
					    "-"))) "Server run"))
		   (th3 (make-thread http-transport:keep-running "Keep running")))

	      ;; Database connection

	      (set! *inmemdb*  (make-dbr:dbstruct path: *toppath*))


	      (thread-start! th2)
	      (thread-start! th3)

	      (set! *didsomething* #t)
	      (thread-join! th2))
	    (debug:print 0 "ERROR: Failed to setup for megatest")))
    (exit)))


















(define (http-transport:server-signal-handler signum)
  (handle-exceptions
   exn
   (debug:print " ... exiting ...")
   (let ((th1 (make-thread (lambda ()
			     (thread-sleep! 1))


			   "eat response"))
	 (th2 (make-thread (lambda ()
			     (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.")
			     (thread-sleep! 3) ;; give the flush three seconds to do it's stuff
			     (debug:print 0 "       Done.")
			     (exit 4))
			   "exit on ^C timer")))
︙︙

Modified server.scm from [00385235c5] to [ddc244d255].

︙︙
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65

      (if (not (setup-for-run))
	  (begin
	    (debug:print 0 "ERROR: cannot find megatest.config, exiting")
	    (exit))))
  (debug:print-info 2 "Starting server using " transport " transport")
  (set! *transport-type* transport)
  (case transport
    ((fs)   (exit)) ;; there is no "fs" server transport
    ((http) (http-transport:launch))
    ((zmq)  (zmq-transport:launch))
    (else
     (debug:print "WARNING: unrecognised transport " transport)
     (exit))))

;;======================================================================
;; Q U E U E   M A N A G E M E N T
;;======================================================================








|
|
|








49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65

      (if (not (setup-for-run))
	  (begin
	    (debug:print 0 "ERROR: cannot find megatest.config, exiting")
	    (exit))))
  (debug:print-info 2 "Starting server using " transport " transport")
  (set! *transport-type* transport)
  (case transport
    ;; ((fs)   (exit)) ;; there is no "fs" server transport
    ((fs http) (http-transport:launch))
    ((zmq)     (zmq-transport:launch))
    (else
     (debug:print "WARNING: unrecognised transport " transport)
     (exit))))

;;======================================================================
;; Q U E U E   M A N A G E M E N T
;;======================================================================
︙︙

This page was generated in about 0.109s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00