Megatest

Check-in [41642e0600]
Login
Overview
Comment:It compiles
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.6584-ck5
Files: files | file ages | folders
SHA1: 41642e0600df69dfbd125437b9243bb84664c36d
User & Date: matt on 2021-04-07 19:00:56
Other Links: branch diff | manifest | tags
Context
2021-04-07
20:15
Added missing file check-in: 984d886371 user: matt tags: v1.6584-ck5
19:00
It compiles check-in: 41642e0600 user: matt tags: v1.6584-ck5
09:41
wip check-in: 07c8d202ea user: matt tags: v1.6584-ck5
Changes

Modified Makefile from [fa568d064b] to [7db0c5f9d8].

30
31
32
33
34
35
36
37

38

39
40
41
42
43
44
45
#            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


# 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







|
>
|
>







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

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),)







|







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/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
    (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)))

;;======================================================================
;; S T A T E S   A N D   S T A T U S E S
;;======================================================================

;; BBnote: *common:std-states* - dashboard filter control and test control state buttons defined here; used in set-fields-panel and dboard:make-controls
(define *common:std-states*   ;; for toggle buttons in dashboard
  '(







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







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














































;;======================================================================
;; S T A T E S   A N D   S T A T U S E S
;;======================================================================

;; BBnote: *common:std-states* - dashboard filter control and test control state buttons defined here; used in set-fields-panel and dboard:make-controls
(define *common:std-states*   ;; for toggle buttons in dashboard
  '(
1008
1009
1010
1011
1012
1013
1014

1015
1016
1017
1018
1019
1020
1021
1022
  (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)

  (thread-sleep! 0.05) ;; 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)))







>
|







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! 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
;; 
;;     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))


(module commonmod
	*
	
(import scheme chicken.base









	(prefix sqlite3 sqlite3:)
	

	typed-records
	md5
	message-digest
	regex

	srfi-1
	srfi-18
	srfi-69


	)

;;======================================================================
;; CONTENTS
;;
;;  config file utils
;;  misc conversion, data manipulation functions
;;  testsuite and area utilites
;;
;;======================================================================

(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")

;; (define (get-full-version)
;;   (conc megatest-version "-" megatest-fossil-hash))
;; 
;; (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))

)







>




|
>
>
>
>
>
>
>
>
>


>




<




>











<


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


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

	srfi-1
	srfi-18
	srfi-69

	mtver
	)

;;======================================================================
;; CONTENTS
;;
;;  config file utils
;;  misc conversion, data manipulation functions
;;  testsuite and area utilites
;;
;;======================================================================


(include "megatest-fossil-hash.scm")

;; 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 (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.251)




	  (if (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)))








)

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
;;     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))))

;;======================================================================
;; SQLITE3 HELPERS
;;======================================================================

(define (db:general-sqlite-error-dump exn stmt . params)
  (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; RADT ... how does this work?
    ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn)







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







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/>.
;;
;;======================================================================
























































































;;======================================================================
;; SQLITE3 HELPERS
;;======================================================================

(define (db:general-sqlite-error-dump exn stmt . params)
  (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; RADT ... how does this work?
    ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn)

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
	
(import scheme
	chicken.base
	(prefix sqlite3 sqlite3:)

	typed-records
	srfi-18


	)




(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))


































)







>
|


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

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


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
;;======================================================================

;; 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 debugprint.scm from [d70c06632a] to [668a77fa42].

1
2
3
4
5
6
7
8
9
(declare (unit debugprint))
(declare (uses margsmod))

(module debugprint
	*
	
;;(import scheme chicken data-structures extras files ports)
(import scheme
	chicken.base

|







1
2
3
4
5
6
7
8
9
(declare (unit debugprint))
(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
(declare
 (fixnum))

(cond-expand [paranoia]
             [else
              (declare (no-bound-checks))])

#> #include "hostinfo.h" <#

;; (require-extension srfi-4 lolevel posix)

(module hostinfo
;;; Short and sweet lookups
  (current-hostname
   hostname->ip ip->hostname







|







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

(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)
	      (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)







|







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.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
                                    "-")
                                )) "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-start! th3)
      (set! *didsomething* #t)
      (thread-join! th2)
      (exit))))

;; (define (http-transport:server-signal-handler signum)
;;   (signal-mask! signum)







|







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

;; (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 "ducttape/ducttape-lib.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 mtargs))
(declare (uses commonmod))
(declare (uses apimod))
(declare (uses dbmod))
(declare (uses rmtmod))



;; (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





		)
	
;; (include "common.scm")
(include "megatest-version.scm")

;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
(define setenv set-environment-variable!)
(define unsetenv unset-environment-variable!)

;; (declare (uses common))
;; ;; (declare (uses megatest-version))







|

|


|
|
|
|
|
|
>
>
>





|
>






|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

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







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 "ducttape/ducttape-lib.scm")
;; (include "hostinfo/hostinfo.scm")
(include "adjutant.scm")

(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
	  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
	  
	  )


	
;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
(define setenv set-environment-variable!)
(define unsetenv unset-environment-variable!)

;; (declare (uses common))
;; ;; (declare (uses megatest-version))
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
;; (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 *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")
(include "configf.scm")
(include "margs.scm")
(include "process.scm")
(include "keys.scm")
(include "portlogger.scm")
(include "db.scm")
(include "rmt.scm")







>
>








<

<
<
|
>

<







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 "common.scm")
(include "megatest-fossil-hash.scm")


(include "configf.scm")
(include "margs.scm")
(include "process.scm")
(include "keys.scm")
(include "portlogger.scm")
(include "db.scm")
(include "rmt.scm")

Renamed and modified megatest-version.scm [f92dc46346] to mtver.scm [88befd643e].

14
15
16
17
18
19
20
21
22




23


;; 
;;     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))





(define megatest-version 1.6584)









|

>
>
>
>

>
>
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 mtver))

(module mtver *

(import scheme chicken.module)

(define megatest-version 1.6584)

)

Modified rmt.scm from [1b15495d3f] to [9c5b8773ea].

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







|







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.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
					   (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
		(if (null? tal)
		    newthreads
		    (loop (car tal)(cdr tal) newthreads))))))
    result))

;; ;; IDEA: Threadify these - they spend a lot of time waiting ...
;; ;;







|







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.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
;;     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")

(module rmtmod
	*
	
(import scheme 
	(prefix sqlite3 sqlite3:)








<
<
<
<







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





(module rmtmod
	*
	
(import scheme 
	(prefix sqlite3 sqlite3:)

Modified runs.scm from [da78ed5fd8] to [b5b3c41539].

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)
      ;; 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)







|







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.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
;; ;;(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))

;;======================================================================
;; P K T S   S T U F F 
;;======================================================================

;; ???

;;======================================================================







<
<
<
<
<
<
<







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")








;;======================================================================
;; P K T S   S T U F F 
;;======================================================================

;; ???

;;======================================================================
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
                   (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)))))))))

;; 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)))







|







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

;; 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
		   (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"))
               (server-logs   (string-split (string-chomp (call-with-input-pipe server-logs-cmd read-string))))
	       (num-serv-logs (length server-logs)))
	  (if (or (null? server-logs) (= num-serv-logs 0))
              (let ()
                 (debug:print 1  *default-log-port* "There are no servers running")
	         '()
              )
	      (let loop ((hed  (string-chomp (car server-logs)))







|
<







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   (server:get-logs-list areapath))

	       (num-serv-logs (length server-logs)))
	  (if (or (null? server-logs) (= num-serv-logs 0))
              (let ()
                 (debug:print 1  *default-log-port* "There are no servers running")
	         '()
              )
	      (let loop ((hed  (string-chomp (car server-logs)))
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
	       (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)
		     (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: "







|







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.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
      (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
  (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







|







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.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))
  

)