Overview
Context
Changes
Modified Makefile
from [fa568d064b]
to [7db0c5f9d8].
| ︙ | | |
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
|
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
|
-
-
+
+
+
+
|
# ezsteps.scm lock-queue.scm sdb.scm rmt.scm api.scm \
# subrun.scm portlogger.scm archive.scm env.scm \
# diff-report.scm cgisetup/models/pgdb.scm
# module source files
# MSRCFILES =
# ftail.scm rmtmod.scm commonmod.scm removed
MSRCFILES = autoload.scm dbi.scm ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm \
mtargs.scm apimod.scm commonmod.scm dbmod.scm rmtmod.scm debugprint.scm
MSRCFILES = autoload.scm dbi.scm ducttape-lib.scm pkts.scm stml2.scm \
cookie.scm mutils.scm mtargs.scm apimod.scm commonmod.scm \
dbmod.scm rmtmod.scm debugprint.scm mtver.scm \
csv-xml.scm servermod.scm hostinfo.scm
# commonmod.scm dbmod.scm adjutant.scm ulex.scm \
# rmtmod.scm apimod.scm
GUISRCF = dashboard-context-menu.scm dashboard-tests.scm \
dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm \
vg.scm
|
| ︙ | | |
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
|
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
|
-
+
|
mkdir -p mofiles
csc $(CSCOPTS) -J -c $< -o mofiles/$*.o
# module dependencies
mofiles/stml2.o : mofiles/dbi.o
mofiles/dbi.o : mofiles/autoload.o
mofiles/apimod.o mofiles/dbmod.o mofiles/rmtmod.o : mofiles/commonmod.o
mofiles/commonmod.o : mofiles/mtargs.o mofiles/debugprint.o
mofiles/commonmod.o : mofiles/mtargs.o mofiles/debugprint.o mofiles/megatest-version.o
ADTLSCR=mt_laststep mt_runstep mt_ezstep
HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR))
DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR))
MTESTHASH=$(shell fossil info|grep checkout:| awk '{print $$2}')
ifeq ($(MTESTHASH),)
|
| ︙ | | |
Modified common.scm
from [27221087b7]
to [1b32ae0d45].
| ︙ | | |
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
|
728
729
730
731
732
733
734
735
736
737
738
739
740
741
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
(begin
(debug:print-error 0 *default-log-port* "received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
(print-call-chain (current-error-port))
#f)
(read (open-input-string (base64:base64-decode instr))))
(read (open-input-string (z3:decode-buffer (base64:base64-decode instr))))))
;; dot-locking egg seems not to work, using this for now
;; if lock is older than expire-time then remove it and try again
;; to get the lock
;;
(define (common:simple-file-lock fname #!key (expire-time 300))
(let ((fmod-time (handle-exceptions
ext
(current-seconds)
(file-modification-time fname))))
(if (common:file-exists? fname)
(if (> (- (current-seconds) fmod-time) expire-time)
(begin
(handle-exceptions exn #f (delete-file* fname))
(common:simple-file-lock fname expire-time: expire-time))
#f)
(let ((key-string (conc (get-host-name) "-" (current-process-id))))
(with-output-to-file fname
(lambda ()
(print key-string)))
(thread-sleep! 0.25)
(if (common:file-exists? fname)
(handle-exceptions exn
#f
(with-input-from-file fname
(lambda ()
(equal? key-string (read-line)))))
#f)))))
(define (common:simple-file-lock-and-wait fname #!key (expire-time 300))
(let ((end-time (+ expire-time (current-seconds))))
(let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time)))
(if got-lock
#t
(if (> end-time (current-seconds))
(begin
(thread-sleep! 3)
(loop (common:simple-file-lock fname expire-time: expire-time)))
#f)))))
(define (common:simple-file-release-lock fname)
(handle-exceptions
exn
#f ;; I don't really care why this failed (at least for now)
(delete-file* fname)))
|
| ︙ | | |
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
|
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
|
+
-
+
|
(time->string (seconds->local-time (current-seconds)) "%Y-%m-%d %H:%M:%S"))
;;======================================================================
;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp
;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server)
;;
(define (common:readonly-watchdog dbstruct)
(let ((just-testing 0.0501))
(thread-sleep! 0.05) ;; delay for startup
(thread-sleep! just-testing)) ;; (/ 1 20)) ;; 0.051) ;; delay for startup
(debug:print-info 13 *default-log-port* "common:readonly-watchdog entered.")
;; sync megatest.db to /tmp/.../megatst.db
(let* ((sync-cool-off-duration 3)
(golden-mtdb (dbr:dbstruct-mtdb dbstruct))
(golden-mtpath (db:dbdat-get-path golden-mtdb))
(tmp-mtdb (dbr:dbstruct-tmpdb dbstruct))
(tmp-mtpath (db:dbdat-get-path tmp-mtdb)))
|
| ︙ | | |
Modified commonmod.scm
from [7df3d9436f]
to [b5e3523a1c].
| ︙ | | |
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
|
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
|
+
-
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
+
+
+
-
-
-
+
-
-
-
-
-
-
+
-
-
-
-
-
+
-
-
+
+
-
-
+
-
-
-
-
-
-
-
+
-
+
+
-
-
-
-
-
-
-
-
+
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
-
-
-
-
+
+
+
+
-
-
-
-
-
-
-
-
+
+
+
+
+
+
-
-
-
+
+
-
-
-
-
-
+
-
-
-
-
+
+
+
-
-
+
-
-
-
-
-
-
+
+
+
+
+
-
-
-
-
-
-
-
-
+
-
-
-
+
-
-
-
-
-
-
+
+
-
-
-
-
-
-
+
-
-
-
-
-
-
-
-
+
+
-
-
-
-
-
-
|
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
(declare (unit commonmod))
(declare (uses mtver))
(module commonmod
*
(import scheme chicken.base
(import scheme
chicken.base
chicken.condition
chicken.file
chicken.time
chicken.file.posix
chicken.process-context.posix
chicken.io
chicken.string
(prefix sqlite3 sqlite3:)
system-information
typed-records
md5
message-digest
regex
(include "megatest-version.scm")
;; (define (get-full-version)
;; (conc megatest-version "-" megatest-fossil-hash))
;;
;; 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 (version-signature)
;; (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
;;
;;
;; ;;======================================================================
;; ;; config file utils
;; ;;======================================================================
;;
;; (define (lookup cfgdat section var)
;; (if (hash-table? cfgdat)
;; (let ((sectdat (hash-table-ref/default cfgdat section '())))
;; (if (null? sectdat)
;; #f
;; (let ((match (assoc var sectdat)))
;; (if match ;; (and match (list? match)(> (length match) 1))
;; (cadr match)
;; #f))
;; ))
;; #f))
;;
;; ;; returns var key1=val1; key2=val2 ... as alist
;; (define (get-key-list cfgdat section var)
;; ;; convert string a=1; b=2; c=a silly thing; d=
;; (let ((valstr (lookup cfgdat section var)))
;; (if valstr
;; (val->alist valstr)
;; '()))) ;; should it return empty list or #f to indicate not set?
;;
;;
;; (define (get-section cfgdat section)
;; (hash-table-ref/default cfgdat section '()))
;;
;; ;;======================================================================
;; ;; misc conversion, data manipulation functions
;; ;;======================================================================
;;
;; ;; if it looks like a number -> convert it to a number, else return it
;; ;;
;; (define (lazy-convert inval)
;; (let* ((as-num (if (string? inval)(string->number inval) #f)))
;; (or as-num inval)))
;;
;; ;; to '((a . 1)(b . 2)(c . "a silly thing")(d . ""))
;; ;;
;; (define (val->alist val #!key (convert #f))
;; (let ((val-list (string-split-fields ";\\s*" val #:infix)))
;; (if val-list
;; (map (lambda (x)
;; (let ((f (string-split-fields "\\s*=\\s*" x #:infix)))
;; (case (length f)
;; ((0) `(,#f)) ;; null string case
;; ((1) `(,(string->symbol (car f))))
;; ((2) `(,(string->symbol (car f)) .
;; ,(let ((inval (cadr f)))
;; (if convert (lazy-convert inval) inval))))
;; (else f))))
;; (filter (lambda (x)
;; (not (string-match "^\\s*" x)))
;; val-list))
;; '())))
;;
;; ;;======================================================================
;; ;; testsuite and area utilites
;; ;;======================================================================
;;
;; (define (get-testsuite-name toppath configdat)
;; (or (lookup configdat "setup" "area-name")
;; (lookup configdat "setup" "testsuite")
;; (get-environment-variable "MT_TESTSUITE_NAME")
;; (if (string? toppath)
;; (pathname-file toppath)
;; #f)))
;;
;; (define (get-area-path-signature toppath #!optional (short #f))
;; (let ((res (message-digest-string (md5-primitive) toppath)))
;; (if short
;; (substring res 0 4)
;; res)))
;;
;; (define (get-area-name configdat toppath #!optional (short #f))
;; ;; look up my area name in areas table (future)
;; ;; generate auto name
;; (conc (get-area-path-signature toppath short)
;; "-"
;; (get-testsuite-name toppath configdat)))
;;
;; ;; need generic find-record-with-var-nmatching-val
;; ;;
;; (define (path->area-record cfgdat path)
;; (let* ((areadat (get-cfg-areas cfgdat))
;; (all (filter (lambda (x)
;; (let* ((keyvals (cdr x))
;; (pth (alist-ref 'path keyvals)))
;; (equal? path pth)))
;; areadat)))
;; (if (null? all)
;; #f
;; (car all)))) ;; return first match
;;
;; ;; given a config return an alist of alists
;; ;; area-name => data
;; ;;
;; (define (get-cfg-areas cfgdat)
;; (let ((adat (get-section cfgdat "areas")))
;; (map (lambda (entry)
;; `(,(car entry) .
;; ,(val->alist (cadr entry))))
;; adat)))
;;
;; ;; (define (debug:print . params) #f)
;; ;; (define (debug:print-info . params) #f)
;; ;;
;; ;; (define (set-functions dbgp dbgpinfo)
;; ;; (set! debug:print dbgp)
;; ;; (set! debug:print-info dbgpinfo))
|
Modified db.scm
from [036e2d264f]
to [d384bd54d1].
| ︙ | | |
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
|
14
15
16
17
18
19
20
21
22
23
24
25
26
27
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;
;;======================================================================
;;======================================================================
;; Database access
;;======================================================================
;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc
;; (use (srfi 18) extras tcp stack)
;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records matchable)
;; (import (prefix sqlite3 sqlite3:))
;; (import (prefix base64 base64:))
;;
;; (declare (unit db))
;; (declare (uses common))
;; (declare (uses keys))
;; (declare (uses ods))
;; (declare (uses client))
;; (declare (uses mt))
;;
;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "key_records.scm")
;; (include "run_records.scm")
(define *number-of-writes* 0)
(define *number-non-write-queries* 0)
;;======================================================================
;; R E C O R D S
;;======================================================================
;; each db entry is a pair ( db . dbfilepath )
;; I propose this record evolves into the area record
;;
(defstruct dbr:dbstruct
(tmpdb #f)
(dbstack #f) ;; stack for tmp db handles, do not initialize with a stack
(mtdb #f)
(refndb #f)
(homehost #f) ;; not used yet
(on-homehost #f) ;; not used yet
(read-only #f)
(stmt-cache (make-hash-table))
(locdbs (make-hash-table)) ;; legacy junk in db_records
) ;; goal is to converge on one struct for an area but for now it is too confusing
;; record for keeping state,status and count for doing roll-ups in
;; iterated tests
;;
(defstruct dbr:counts
(state #f)
(status #f)
(count 0))
;;======================================================================
;; alist-of-alists
;;======================================================================
;;
;; (define (db:aa-set! dat key1 key2 val)
;; (let loop ((
;;======================================================================
;; hash of hashs
;;======================================================================
(define (db:hoh-set! dat key1 key2 val)
(let* ((subhash (hash-table-ref/default dat key1 #f)))
(if subhash
(hash-table-set! subhash key2 val)
(begin
(hash-table-set! dat key1 (make-hash-table))
(db:hoh-set! dat key1 key2 val)))))
(define (db:hoh-get dat key1 key2)
(let* ((subhash (hash-table-ref/default dat key1 #f)))
(and subhash
(hash-table-ref/default subhash key2 #f))))
(define (db:get-cache-stmth dbstruct db stmt)
(let* ((stmt-cache (dbr:dbstruct-stmt-cache dbstruct))
(stmth (db:hoh-get stmt-cache db stmt)))
(or stmth
(let* ((newstmth (sqlite3:prepare db stmt)))
(db:hoh-set! stmt-cache db stmt newstmth)
newstmth))))
|
| ︙ | | |
Modified dbmod.scm
from [8c2e07af41]
to [f2badf7d83].
| ︙ | | |
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
|
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
|
+
-
+
+
+
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(import scheme
chicken.base
(prefix sqlite3 sqlite3:)
typed-records
srfi-18
srfi-69
)
;;======================================================================
;; Database access
;;======================================================================
(define (just-testing)
(print "JUST TESTING"))
;; (define (debug:print . params) #f)
;; (define (debug:print-info . params) #f)
;;
;; (define (set-functions dbgp dbgpinfo)
;; (set! debug:print dbgp)
;; (set! debug:print-info dbgpinfo))
|
Modified debugprint.scm
from [d70c06632a]
to [668a77fa42].
1
2
3
4
5
6
7
8
9
|
1
2
3
4
5
6
7
8
9
|
-
+
|
(declare (unit debugprint))
(declare (uses margsmod))
(declare (uses mtargs))
(module debugprint
*
;;(import scheme chicken data-structures extras files ports)
(import scheme
chicken.base
|
| ︙ | | |
Added hostinfo.scm version [e131d5b66f].
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;;======================================================================
;; Copyright 2019, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; Megatest is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
(declare (unit hostinfo))
(include "hostinfo/hostinfo.scm")
|
| | | | | | | | | | | | | | | | | | | | | |
Modified hostinfo/hostinfo.scm
from [57d098dcb3]
to [15139d566b].
| ︙ | | |
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
|
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
|
-
+
|
(declare
(fixnum))
(cond-expand [paranoia]
[else
(declare (no-bound-checks))])
#> #include "hostinfo.h" <#
#> #include "../hostinfo/hostinfo.h" <#
;; (require-extension srfi-4 lolevel posix)
(module hostinfo
;;; Short and sweet lookups
(current-hostname
hostname->ip ip->hostname
|
| ︙ | | |
Modified http-transport.scm
from [11f0936b19]
to [92216113da].
| ︙ | | |
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
|
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
|
-
+
|
(define (http-transport:dec-requests-count-and-close-all-connections)
(set! *http-requests-in-progress* (- *http-requests-in-progress* 1))
(let loop ((etime (+ (current-seconds) 5))) ;; give up in five seconds
(if (> *http-requests-in-progress* 0)
(if (> etime (current-seconds))
(begin
(thread-sleep! 0.05)
(thread-sleep! 0.052)
(loop etime))
(debug:print-error 0 *default-log-port* "requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections"))
(close-idle-connections!)))
(set! *http-connections-next-cleanup* (+ (current-seconds) 10))
(mutex-unlock! *http-mutex*))
(define (http-transport:inc-requests-and-prep-to-close-all-connections)
|
| ︙ | | |
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
|
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
|
-
+
|
"-")
)) "Server run"))
(th3 (make-thread (lambda ()
(debug:print-info 0 *default-log-port* "Server monitor thread started")
(http-transport:keep-running)
"Keep running"))))
(thread-start! th2)
(thread-sleep! 0.25) ;; give the server time to settle before starting the keep-running monitor.
(thread-sleep! 0.252) ;; give the server time to settle before starting the keep-running monitor.
(thread-start! th3)
(set! *didsomething* #t)
(thread-join! th2)
(exit))))
;; (define (http-transport:server-signal-handler signum)
;; (signal-mask! signum)
|
| ︙ | | |
Modified megatest.scm
from [f055a75702]
to [2a8c23771e].
| ︙ | | |
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
|
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
|
-
+
-
+
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
-
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
+
|
;; (include "mutils/mutils.scm")
;; (include "autoload/autoload.scm")
;; (include "dbi/dbi.scm")
;; (include "stml2/cookie.scm")
;; (include "stml2/stml2.scm")
;; (include "pkts/pkts.scm")
(include "csv-xml/csv-xml.scm")
;; (include "csv-xml/csv-xml.scm")
;; (include "ducttape/ducttape-lib.scm")
(include "hostinfo/hostinfo.scm")
;; (include "hostinfo/hostinfo.scm")
(include "adjutant.scm")
(declare (uses mutils))
(declare (uses autoload))
(declare (uses pkts))
(declare (uses ducttape-lib))
(declare (uses stml2))
(declare (uses cookie))
(declare (uses autoload))
(declare (uses pkts))
(declare (uses stml2))
(declare (uses cookie))
(declare (uses csv-xml))
(declare (uses hostinfo))
(declare (uses mutils))
(declare (uses ducttape-lib))
(declare (uses mtargs))
(declare (uses commonmod))
(declare (uses apimod))
(declare (uses dbmod))
(declare (uses rmtmod))
(declare (uses servermod))
(declare (uses mtver))
;; (include "call-with-environment-variables/call-with-environment-variables.scm")
(module megatest-main
*
(import scheme
chicken.base
chicken.bitwise
chicken.condition
chicken.file
chicken.file.posix
chicken.format
chicken.io
chicken.irregex
chicken.pathname
chicken.port
chicken.pretty-print
chicken.process
chicken.process-context
chicken.process-context.posix
chicken.process.signal
chicken.random
chicken.repl
chicken.sort
chicken.string
chicken.tcp
chicken.time
chicken.time.posix
(prefix sqlite3 sqlite3:)
(prefix base64 base64:)
address-info
csv-abnf
directory-utils
fmt
json
matchable
md5
message-digest
queues
regex
regex-case
sql-de-lite
stack
typed-records
s11n
sparse-vectors
sxml-serializer
sxml-modifications
system-information
z3
spiffy
uri-common
intarweb
http-client
spiffy-request-vars
intarweb
spiffy-directory-listing
srfi-1
srfi-4
srfi-18
srfi-13
srfi-98
srfi-69
;; local modules
mutils
csv-xml
ducttape-lib
hostinfo
adjutant
)
;; local modules
adjutant
csv-xml
ducttape-lib
hostinfo
mtver
mutils
autoload
cookie
csv-xml
ducttape-lib
mtargs
pkts
stml2
(prefix dbi dbi:)
apimod
commonmod
dbmod
rmtmod
servermod
)
;; (include "common.scm")
(include "megatest-version.scm")
|
| ︙ | | |
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
|
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
|
+
+
-
-
-
-
+
+
-
|
;; (declare (uses mt))
;; (declare (uses api))
;; (declare (uses tasks)) ;; only used for debugging.
;; (declare (uses env))
;; (declare (uses diff-report))
;; (declare (uses ftail))
;; (import ftail)
(define (blahblah)(thread-sleep! 1.234))
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
(include "megatest-fossil-hash.scm")
(import (prefix dbi dbi:))
(import stml2)
(import pkts)
(include "common.scm")
|
| ︙ | | |
Renamed and modified
megatest-version.scm
[f92dc46346]
to mtver.scm
[88befd643e].
| ︙ | | |
14
15
16
17
18
19
20
21
22
23
|
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
|
-
+
+
+
+
+
+
+
|
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;; 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))
|
Modified rmt.scm
from [1b15495d3f]
to [9c5b8773ea].
| ︙ | | |
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
|
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
|
-
+
|
payload: `((rid . ,rid)
(params . ,params)))
(if (> attemptnum 2)
(debug:print 0 *default-log-port* "INFO: attemptnum in rmt:send-receive is " attemptnum))
(cond
((> attemptnum 2) (thread-sleep! 0.05))
((> attemptnum 2) (thread-sleep! 0.053))
((> attemptnum 10) (thread-sleep! 0.5))
((> attemptnum 20) (thread-sleep! 1)))
(if (and (> attemptnum 5) (= 0 (modulo attemptnum 15)))
(begin (server:run *toppath*) (thread-sleep! 3)))
;;DOT digraph megatest_state_status {
|
| ︙ | | |
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
|
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
|
-
+
|
(mutex-lock! multi-run-mutex)
(set! result (append result res))
(mutex-unlock! multi-run-mutex))
(debug:print-error 0 *default-log-port* "get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in))))
(conc "multi-run-thread for run-id " hed)))
(newthreads (cons newthread threads)))
(thread-start! newthread)
(thread-sleep! 0.05) ;; give that thread some time to start
(thread-sleep! 0.054) ;; give that thread some time to start
(if (null? tal)
newthreads
(loop (car tal)(cdr tal) newthreads))))))
result))
;; ;; IDEA: Threadify these - they spend a lot of time waiting ...
;; ;;
|
| ︙ | | |
Modified rmtmod.scm
from [0156172ddd]
to [cb38f42270].
| ︙ | | |
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
|
17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
-
-
-
-
|
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
(declare (unit rmtmod))
(declare (uses commonmod))
(declare (uses apimod))
;; (declare (uses apimod.import))
(declare (uses ulex))
;; (include "ulex/ulex.scm")
|
| ︙ | | |
Modified runs.scm
from [da78ed5fd8]
to [b5b3c41539].
| ︙ | | |
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
|
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
|
-
+
|
;; If no resources are available just kill time and loop again
;;
((not have-resources) ;; simply try again after waiting a second
(if (runs:lownoise "no resources" 60)
(debug:print-info 1 *default-log-port* "no resources to run new tests, waiting ..."))
;; Have gone back and forth on this but db starvation is an issue.
;; wait one second before looking again to run jobs.
(thread-sleep! 0.25)
(thread-sleep! 0.253)
;; could have done hed tal here but doing car/cdr of newtal to rotate tests
(list (car newtal)(cdr newtal) reg reruns))
;; This is the final stage, everything is in place so launch the test
;;
((and have-resources
(or (null? prereqs-not-met)
|
| ︙ | | |
Modified server.scm
from [0f1ce40290]
to [ec8310146f].
| ︙ | | |
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
|
33
34
35
36
37
38
39
40
41
42
43
44
45
46
|
-
-
-
-
-
-
-
|
;; ;;(declare (uses rpc-transport))
;; (declare (uses launch))
;; ;; (declare (uses daemon))
;;
;; (include "common_records.scm")
;; (include "db_records.scm")
(define (server:make-server-url hostport)
(if (not hostport)
#f
(conc "http://" (car hostport) ":" (cadr hostport))))
(define *server-loop-heart-beat* (current-seconds))
|
| ︙ | | |
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
|
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
|
-
+
|
(if dbprep-found
(begin
(debug:print-info 0 *default-log-port* "Server is in dbprep at " (current-seconds))
(thread-sleep! 25)
)
(debug:print-info 0 *default-log-port* "Unable to get server info from " logf " at " (current-seconds))
)
(list #f #f #f #f)))))))))
(list #f #f #f #f)))))))))
;; get a list of servers with all relevant data
;; ( mod-time host port start-time pid )
;;
(define (server:get-list areapath #!key (limit #f))
(let ((fname-rx (regexp "^(|.*/)server-(\\d+)-(\\S+).log$"))
(day-seconds (* 24 60 60)))
|
| ︙ | | |
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
|
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
|
-
+
-
|
(create-directory (conc areapath "/logs") #t)
(exn (i/o file)(debug:print 0 *default-log-port* "ERROR: Cannot create directory at " (conc areapath "/logs")))
(exn ()(debug:print 0 *default-log-port* "ERROR: Unknown error attemtping to get server list. exn=" exn)))
(directory-exists? (conc areapath "/logs")))
'()))
;; Get the list of server logs that do not contain "exiting". Ignore logs for servers that have exited.
(let* ((server-logs-cmd (conc "grep -iL exiting " areapath "/logs/server-*-*.log"))
(let* ((server-logs (server:get-logs-list areapath))
(server-logs (string-split (string-chomp (call-with-input-pipe server-logs-cmd read-string))))
|
| ︙ | | |
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
|
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
|
-
+
|
(all-go (> delta reftime)))
(if (and all-go
(begin
(debug:print-info 0 *default-log-port* "Writing " start-flag)
(with-output-to-file start-flag
(lambda ()
(print server-key)))
(thread-sleep! 0.25)
(thread-sleep! 0.254)
(let ((res (with-input-from-file start-flag
(lambda ()
(read-line)))))
(equal? server-key res))))
#t ;; (system (conc "touch " start-flag)) ;; lazy but safe
(begin
(debug:print-info 0 *default-log-port* "Gating server start, last start: "
|
| ︙ | | |
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
|
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
|
-
+
|
(final-sync)
(if (common:low-noise-print 30)
(debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)
)))))
(define (server:writable-watchdog-deltasync dbstruct)
(thread-sleep! 0.05) ;; delay for startup
(thread-sleep! 0.054) ;; delay for startup
(let ((legacy-sync (common:run-sync?))
(sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300))
(debug-mode (debug:debug-mode 1))
(last-time (current-seconds))
(no-sync-db (db:open-no-sync-db))
(stmt-cache (dbr:dbstruct-stmt-cache dbstruct))
(sync-duration 0) ;; run time of the sync in milliseconds
|
| ︙ | | |
Added servermod.scm version [348a7a1225].
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;;======================================================================
;; Copyright 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 servermod))
(module servermod
*
(import scheme
chicken.base
chicken.string
chicken.process
chicken.io
chicken.time
(prefix sqlite3 sqlite3:)
typed-records
srfi-18
srfi-69
)
(define (server:make-server-url hostport)
(if (not hostport)
#f
(conc "http://" (car hostport) ":" (cadr hostport))))
(define *server-loop-heart-beat* (current-seconds))
(define (server:get-logs-list area-path)
(let* ((server-logs-cmd (conc "grep -iL exiting " area-path "/logs/server-*-*.log"))
(server-logs (string-split (string-chomp (with-input-from-pipe server-logs-cmd read-string)))))
server-logs))
)
|
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | |