Overview
Context
Changes
Modified Makefile
from [f00b41cab1]
to [c1e25ebb0b].
| ︙ | | |
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
|
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
|
-
+
|
# 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 mtver.scm csv-xml.scm \
servermod.scm hostinfo.scm adjutant.scm
servermod.scm hostinfo.scm adjutant.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
|
| ︙ | | |
Modified common.scm
from [1b32ae0d45]
to [80d71223a5].
| ︙ | | |
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
-
+
|
(define *already-seen-runconfig-info* #f)
(define *test-meta-updated* (make-hash-table))
(define *globalexitstatus* 0) ;; attempt to work around possible thread issues
(define *passnum* 0) ;; when running track calls to run-tests or similar
;; (define *alt-log-file* #f) ;; used by -log
(define *common:denoise* (make-hash-table)) ;; for low noise printing
(define *default-log-port* (current-error-port))
;; (define *default-log-port* (current-error-port))
(define *time-zero* (current-seconds)) ;; for the watchdog
(define *default-area-tag* "local")
;; DATABASE
(define *dbstruct-db* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this.
;; db stats
(define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total >
|
| ︙ | | |
Modified commonmod.scm
from [b5e3523a1c]
to [d67fdb6f8a].
| ︙ | | |
55
56
57
58
59
60
61
62
63
64
65
66
67
68
|
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
|
+
+
+
+
|
;; misc conversion, data manipulation functions
;; testsuite and area utilites
;;
;;======================================================================
(include "megatest-fossil-hash.scm")
;; Globals
;;
(define *server-loop-heart-beat* (current-seconds))
;; 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
|
| ︙ | | |
Modified ducttape/ducttape-lib.scm
from [c4ffa8169c]
to [61456ff87b].
| ︙ | | |
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
|
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
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
-
-
-
+
+
+
+
+
|
current-wwdate
current-isodate
*this-exe-dir*
*this-exe-name*
*this-exe-fullpath*
)
(import scheme
chicken.base
chicken.condition
chicken.file
chicken.file.posix
chicken.format
chicken.io
chicken.pathname
chicken.port
chicken.process
chicken.process
chicken.process-context
chicken.process-context.posix
chicken.irregex
chicken.string
chicken.time
chicken.time.posix
)
(import scheme chicken.base chicken.port chicken.process chicken.io chicken.pathname chicken.process-context chicken.time chicken.process chicken.condition chicken.time.posix chicken.process-context.posix chicken.format chicken.file.posix)
(import regex ansi-escape-sequences test srfi-1 chicken.irregex slice srfi-13 rfc3339)
(import pathname-expand chicken.file chicken.string)
(define ##sys#expand-home-path pathname-expand)
(define (realpath x) (print "Path: " x) (normalize-pathname (pathname-expand (or x "/dev/null")) ))
;; (import pathname-expand chicken.file chicken.string)
;; (define ##sys#expand-home-path pathname-expand)
;; (define (realpath x) (print "Path: " x) (normalize-pathname (pathname-expand (or x "/dev/null")) ))
;;(define (realpath x) (pathname-expand (or x "/dev/null")))
(define (realpath x)
(with-input-from-pipe (conc "readlink -f " x) read-line))
;; (include "mimetypes.scm") ; provides ext->mimetype
;; (include "workweekdate.scm")
;; gathered from macosx:
;; cat /etc/apache2/mime.types | grep -v '^#' | perl -ne 'print "(\"$2\" . \"$1\")\n" if /(\S+)\s+(\S+)/' > mimetypes.scm
;; + manual manipulation
|
| ︙ | | |
Modified http-transport.scm
from [92216113da]
to [c31ccc25ed].
| ︙ | | |
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
|
44
45
46
47
48
49
50
51
52
53
54
55
56
57
|
-
-
|
;; (require-library stml)
(define (http-transport:make-server-url hostport)
(if (not hostport)
#f
(conc "http://" (car hostport) ":" (cadr hostport))))
(define *server-loop-heart-beat* (current-seconds))
|
| ︙ | | |
Modified megatest.scm
from [165242d338]
to [a64d336b91].
| ︙ | | |
94
95
96
97
98
99
100
101
102
103
104
105
106
107
|
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
|
+
+
|
sql-de-lite
stack
typed-records
s11n
sparse-vectors
sxml-serializer
sxml-modifications
(prefix sxml-modifications sxml-)
sxml-transforms
system-information
z3
spiffy
uri-common
intarweb
http-client
spiffy-request-vars
|
| ︙ | | |
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
|
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
|
-
+
|
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
(include "common.scm")
(include "megatest-fossil-hash.scm")
;; (include "megatest-fossil-hash.scm")
(include "configf.scm")
(include "margs.scm")
(include "process.scm")
(include "keys.scm")
(include "portlogger.scm")
(include "db.scm")
|
| ︙ | | |
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
|
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
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;;;
;;; ;; Added for csv stuff - will be removed
;;; ;;
;;; ;; (use sparse-vectors)
;;; ;;
;;; ;; (require-library mutils)
;;;
;;; ;; copied from egg call-with-environment-variables
;;; ;;
;;; (define (call-with-environment-variables variables thunk)
;;; ;; @("Sets up environment variable via dynamic-wind which are taken down after thunk."
;;; ;; (variables "An alist of the form {{'((\"var\" . \"value\") ...)}}")
;;; ;; (thunk "The thunk to execute with a modified environment"))
;;; (let ((pre-existing-variables
;;; (map (lambda (var-value)
;;; (let ((var (car var-value)))
;;; (cons var (get-environment-variable var))))
;;; variables)))
;;; (dynamic-wind
;;; (lambda () (void))
;;; (lambda ()
;;; ;; (use posix)
;;; (for-each (lambda (var-value)
;;; (setenv (car var-value) (cdr var-value)))
;;; variables)
;;; (thunk))
;;; (lambda ()
;;; (for-each (lambda (var-value)
;;; (let ((var (car var-value))
;;; (value (cdr var-value)))
;;; (if value
;;; (setenv var value)
;;; (unsetenv var))))
;;; pre-existing-variables)))))
;;;
|
| ︙ | | |
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
|
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
|
+
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
|
;;; ;;
;;; (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
;;; (if targ (setenv "MT_TARGET" targ)))
;;;
;;; ;; The watchdog is to keep an eye on things like db sync etc.
;;; ;;
;;;
;;; ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
;;; (define *watchdog* (make-thread
;;; (lambda ()
;;; (handle-exceptions
;;; exn
;;; (begin
;;; (print-call-chain)
;;; (print " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn))
;;; (common:watchdog)))
;;; "Watchdog thread"))
;;;
|
| ︙ | | |
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
|
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
|
+
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;;; targets))
;;; ((json)
;;; (json-write targets))
;;; (else
;;; (debug:print-error 0 *default-log-port* "dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets")))
;;; (set! *didsomething* #t))))
;;;
;;; ;; cache the runconfigs in $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME/.runconfig
;;; ;;
;;; (define (full-runconfigs-read)
;;; ;; in the envprocessing branch the below code replaces the further below code
;;; ;; (if (eq? *configstatus* 'fulldata)
;;; ;; *runconfigdat*
;;; ;; (begin
;;; ;; (launch:setup)
;;; ;; *runconfigdat*)))
;;;
;;; (let* ((rundir (if (and (getenv "MT_LINKTREE")(getenv "MT_TARGET")(getenv "MT_RUNNAME"))
;;; (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME"))
;;; #f))
;;; (cfgf (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f)))
;;; (if (and cfgf
;;; (common:file-exists? cfgf)
;;; (file-writable? cfgf)
;;; (common:use-cache?))
;;; (configf:read-alist cfgf)
;;; (let* ((keys (rmt:get-keys))
;;; (target (common:args-get-target))
;;; (key-vals (if target (keys:target->keyval keys target) #f))
;;; (sections (if target (list "default" target) #f))
;;; (data (begin
;;; (setenv "MT_RUN_AREA_HOME" *toppath*)
;;; (if key-vals
;;; (for-each (lambda (kt)
;;; (setenv (car kt) (cadr kt)))
;;; key-vals))
;;; ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections))))
;;; (runconfig:read (conc *toppath* "/runconfigs.config") target #f))))
;;; (if (and rundir ;; have all needed variabless
;;; (directory-exists? rundir)
;;; (file-writable? rundir))
;;; (begin
;;; (if (not (common:in-running-test?))
;;; (configf:write-alist data cfgf))
;;; ;; force re-read of megatest.config - this resolves circular references between megatest.config
;;; (launch:setup force-reread: #t)
;;; ;; (launch:cache-config) ;; there are two independent config cache locations, turning this one off for now. MRW.
;;; )) ;; we can safely cache megatest.config since we have a valid runconfig
;;; data))))
|
| ︙ | | |
Modified server.scm
from [ec8310146f]
to [c998f525fa].
| ︙ | | |
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
|
-
+
|
(duty-cycle (configf:lookup-number *configdat* "server" "sync-duty-cycle" default: default-duty-cycle))
(last-sync-seconds 10) ;; we will adjust this to a measurement and delay last-sync-seconds * (1 - duty-cycle)
(calculate-off-time (lambda (work-duration duty-cycle)
(* (/ (- 1 duty-cycle) duty-cycle) last-sync-seconds)))
(off-time min-intersync-delay) ;; adjusted in closure below.
(do-a-sync
(lambda ()
(BB> "Start do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync)
;; (BB> "Start do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync)
(let* ((finalres
(let retry-loop ((num-tries 0))
(if (common:simple-file-lock lockfile)
(begin
(cond
((not (or fork-to-background persist-until-sync))
(debug:print 0 *default-log-port* "INFO: syncer thread sleeping for max of (server.minimum-intersync-delay="min-intersync-delay
|
| ︙ | | |
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
|
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
|
-
-
-
+
+
+
-
+
|
(else
(system (conc "/bin/cp "sync-log" "sync-log".fail"))
(debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Sync failed. See log at "sync-log".fail")
(if (file-exists? (conc mtdbfile ".backup"))
(system (conc "/bin/cp "mtdbfile ".backup " mtdbfile)))
#f))))
(common:simple-file-release-lock lockfile)
(BB> "released lockfile: " lockfile)
(when (common:file-exists? lockfile)
(BB> "DID NOT ACTUALLY RELEASE LOCKFILE"))
;; (BB> "released lockfile: " lockfile)
;; (when (common:file-exists? lockfile)
;; (BB> "DID NOT ACTUALLY RELEASE LOCKFILE"))
res2) ;; end let
);; end begin
;; else
(cond
(persist-until-sync
(thread-sleep! 1)
(debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; we're in a fork-to-background so we need to succeed. Let's wait a jiffy and and try again. num-tries="num-tries" (waiting for lockfile="lockfile" to disappear)")
(retry-loop (add1 num-tries)))
(else
(thread-sleep! (max off-time (+ last-sync-seconds min-intersync-delay)))
(debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; not syncing.")
'parallel-sync-in-progress))
) ;; end if got lockfile
)
))
(BB> "End do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync" and result="finalres)
;; (BB> "End do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync" and result="finalres)
finalres)
) ;; end lambda
))
do-a-sync))
(define (server:writable-watchdog-bruteforce dbstruct)
(thread-sleep! 1) ;; delay for startup
|
| ︙ | | |
Modified servermod.scm
from [348a7a1225]
to [6e736887de].
| ︙ | | |
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
|
38
39
40
41
42
43
44
45
46
47
48
49
50
51
|
-
-
|
)
(define (server:make-server-url hostport)
(if (not hostport)
#f
(conc "http://" (car hostport) ":" (cadr hostport))))
(define *server-loop-heart-beat* (current-seconds))
|