Megatest

Diff
Login

Differences From Artifact [af6209faee]:

To Artifact [be25e443c3]:


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

(declare (unit dbmod))
(declare (uses dbfile))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses debugprint))
(declare (uses mtargs))


(module dbmod
	*
	
(import scheme)
	
(cond-expand
 (chicken-4
  (import chicken
	  data-structures
	  srfi-13
	  
	  debugprint
	  extras
	  files
	  (prefix mtargs args:)
	  posix



	  ))
 (chicken-5
  (import chicken.base
	  chicken.condition
	  chicken.file
	  chicken.pathname
	  chicken.process







>

















>
>
|







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

(declare (unit dbmod))
(declare (uses dbfile))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses debugprint))
(declare (uses mtargs))
(declare (uses mtmod))

(module dbmod
	*
	
(import scheme)
	
(cond-expand
 (chicken-4
  (import chicken
	  data-structures
	  srfi-13
	  
	  debugprint
	  extras
	  files
	  (prefix mtargs args:)
	  posix
	  ports
	  csv-xml
	  
	  ))
 (chicken-5
  (import chicken.base
	  chicken.condition
	  chicken.file
	  chicken.pathname
	  chicken.process
60
61
62
63
64
65
66

67
68
69


70
71
72
73
74


75
76
77
78
79
80
81
  ))

(import	format
	(prefix sqlite3 sqlite3:)
	matchable
	typed-records
	regex

	srfi-1
	srfi-18
	srfi-69



	commonmod
	configfmod
	dbfile
	debugprint)



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

(define *number-of-writes* 0)







>



>
>
|



|
>
>







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

(import	format
	(prefix sqlite3 sqlite3:)
	matchable
	typed-records
	regex
	s11n
	srfi-1
	srfi-18
	srfi-69
	z3
	(prefix base64 base64:)
	
	commonmod
	configfmod
	dbfile
	debugprint
	mtmod
	)

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

(define *number-of-writes* 0)
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740

;;======================================================================
;; Moved from dbfile
;;======================================================================

;; wait up to aprox n seconds for a journal to go away
;;
(define (tasks:wait-on-journal path n #!key (remove #f)(waiting-msg #f))
  (if (not (string? path))
      (debug:print-error 0 *default-log-port* "Called tasks:wait-on-journal with path=" path " (not a string)")
      (let ((fullpath (conc path "-journal")))
	(handle-exceptions
	 exn
	 (begin
	   (print-call-chain (current-error-port))
	   (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
	   (debug:print 5 *default-log-port* " exn=" (condition->list exn))
	   (debug:print 0 *default-log-port* "tasks:wait-on-journal failed. Continuing on, you can ignore this call-chain")
	   #t) ;; if stuff goes wrong just allow it to move on
	 (let loop ((journal-exists (file-exists? fullpath))
		    (count          n)) ;; wait ten times ...
	   (if journal-exists
	       (begin
		 (if (and waiting-msg
			  (eq? (modulo n 30) 0))
		     (debug:print 0 *default-log-port* waiting-msg))
		 (if (> count 0)
		     (begin
		       (thread-sleep! 1)
		       (loop (file-exists? fullpath)
			     (- count 1)))
		     (begin
		       (debug:print 0 *default-log-port* "ERROR: removing the journal file " fullpath ", this is not good. Look for disk full, write access and other issues.")
		       (if remove (system (conc "rm -rf " fullpath)))
		       #f)))
	       #t))))))


;;======================================================================
;; M E T A   G E T   A N D   S E T   V A R S
;;======================================================================

;; returns number if string->number is successful, string otherwise
;; also updates *global-delta*







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







705
706
707
708
709
710
711






























712
713
714
715
716
717
718

;;======================================================================
;; Moved from dbfile
;;======================================================================

;; wait up to aprox n seconds for a journal to go away
;;































;;======================================================================
;; M E T A   G E T   A N D   S E T   V A R S
;;======================================================================

;; returns number if string->number is successful, string otherwise
;; also updates *global-delta*
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
       (if (and (null? incompleted)
                (null? oldlaunched)
                (null? toplevels))
           #f
           #t)))))


;; looks up subdb and returns it, if not found then set up
;; and then return it.
;;
#;(define (db:get-db dbstruct run-id)
  (let* ((res (dbfile:get-subdb dbstruct run-id)))
    (if res
	res
	(let* ((newsubdb (make-dbr:subdb)))
	  (dbfile:set-subdb dbstruct run-id newsubdb)
	  (db:open-db dbstruct run-id areapath: (dbr:dbstruct-areapath dbstruct) do-sync: #t)
	  newsubdb))))

;; Get/open a database
;;    if run-id => get run specific db
;;    if #f     => get main db
;;    if run-id is a string treat it as a filename
;;    if db already open - return cachedb
;;    if db not open, open cachedb, rundb and sync then return cachedb
;;    inuse gets set automatically for rundb's
;;
;; (define db:get-db db:get-subdb)

;; (define (db:get-db subdb #;dbstruct run-id) ;; RENAME TO db:get-dbh
;;   ;; (let* ((subdb (dbfile:get-subdb dbstruct run-id)))
;;     (if (stack? (dbr:subdb-dbstack subdb))
;; 	(if (stack-empty? (dbr:subdb-dbstack subdb))
;; 	    (let* ((dbname (db:run-id->dbname run-id))
;; 		   (newdb  (db:open-megatest-db path: (db:dbfile-path)
;; 						name: dbname)))
;; 	      ;; NOTE: pushing on the stack only happens AFTER the handle has been used
;; 	      ;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb)
;; 	      newdb)
;;           (stack-pop! (dbr:subdb-dbstack subdb)))
;; 	(db:open-db subdb run-id))) ;; )


#;(define (db:get-db dbstruct run-id) 
   (let* ((subdb (dbfile:get-subdb dbstruct run-id))
        (dbdat (dbfile:get-dbdat dbstruct run-id)))
        (if (dbr:dbdat? dbdat)
          dbdat
          (dbfile:open-db *dbstruct-dbs* #f db:initialize-main-db)
        )
   )
)

(define-inline (db:generic-error-printout exn . message)
  (print-call-chain (current-error-port))
  (apply debug:print-error 0 *default-log-port* message)
  (debug:print-error 0 *default-log-port* "   params: " params
		     ", error: "     ((condition-property-accessor 'exn 'message)   exn)
		     ", arguments: " ((condition-property-accessor 'exn 'arguments) exn)
		     ", location: "  ((condition-property-accessor 'exn 'location)  exn)







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







1058
1059
1060
1061
1062
1063
1064














































1065
1066
1067
1068
1069
1070
1071
       (if (and (null? incompleted)
                (null? oldlaunched)
                (null? toplevels))
           #f
           #t)))))
















































(define-inline (db:generic-error-printout exn . message)
  (print-call-chain (current-error-port))
  (apply debug:print-error 0 *default-log-port* message)
  (debug:print-error 0 *default-log-port* "   params: " params
		     ", error: "     ((condition-property-accessor 'exn 'message)   exn)
		     ", arguments: " ((condition-property-accessor 'exn 'arguments) exn)
		     ", location: "  ((condition-property-accessor 'exn 'location)  exn)
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
    last-update-time))


;; Open the classic megatest.db file (defaults to open in toppath)
;;
;;   NOTE: returns a dbdat not a dbstruct!
;;
(define (db:open-megatest-db dbpath)
  (let* ((dbexists     (file-exists? dbpath))
	 (db           (db:lock-create-open dbpath
					    (lambda (db)
                                              (db:initialize-main-db db))))
	 (write-access (file-write-access? dbpath)))
    (debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath)
    (if (and dbexists (not write-access))
	(set! *db-write-access* #f))
    ;; (cons db dbpath)))
    (make-dbr:dbdat dbfile: dbpath dbh: db read-only: (not write-access))))








|



|







1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
    last-update-time))


;; Open the classic megatest.db file (defaults to open in toppath)
;;
;;   NOTE: returns a dbdat not a dbstruct!
;;
(define (db:open-megatest-db dbpath #!key (launch-setup #f))
  (let* ((dbexists     (file-exists? dbpath))
	 (db           (db:lock-create-open dbpath
					    (lambda (db)
                                              (db:initialize-main-db db launch-setup: launch-setup))))
	 (write-access (file-write-access? dbpath)))
    (debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath)
    (if (and dbexists (not write-access))
	(set! *db-write-access* #f))
    ;; (cons db dbpath)))
    (make-dbr:dbdat dbfile: dbpath dbh: db read-only: (not write-access))))

1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304


1305
1306
1307
1308
1309
1310
1311
      (debug:print 2 *default-log-port* "not doing cached calls right now"))
;;      (apply db:call-with-cached-db db-cmd params)
      (apply rmt-cmd params))
;;)

;; return the target db handle so it can be used
;;
(define (db:cache-for-read-only source target #!key (use-last-update #f))
  (if (and (hash-table-ref/default *global-db-store* target #f)
	   (>= (file-modification-time target)(file-modification-time source)))
      (hash-table-ref *global-db-store* target)
      (let* ((toppath   (launch:setup))


	     (targ-db-last-mod (db:get-sqlite3-mod-time target))
;;	      (if (common:file-exists? target)
;; BUG: This needs to include wal mode stuff .shm etc.
;;				   (file-modification-time target)
;;				   0))
	     (cache-db  (or (hash-table-ref/default *global-db-store* target #f)
			    (db:open-megatest-db path: target)))







|



|
>
>







1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
      (debug:print 2 *default-log-port* "not doing cached calls right now"))
;;      (apply db:call-with-cached-db db-cmd params)
      (apply rmt-cmd params))
;;)

;; return the target db handle so it can be used
;;
(define (db:cache-for-read-only source target #!key (use-last-update #f)(launch-setup #f))
  (if (and (hash-table-ref/default *global-db-store* target #f)
	   (>= (file-modification-time target)(file-modification-time source)))
      (hash-table-ref *global-db-store* target)
      (let* ((toppath   (if *toppath*
			    *toppath*
			    (launch-setup)))
	     (targ-db-last-mod (db:get-sqlite3-mod-time target))
;;	      (if (common:file-exists? target)
;; BUG: This needs to include wal mode stuff .shm etc.
;;				   (file-modification-time target)
;;				   0))
	     (cache-db  (or (hash-table-ref/default *global-db-store* target #f)
			    (db:open-megatest-db path: target)))
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
;; Sync all changed db's
;;
(define (db:tmp->megatest.db-sync dbstruct run-id last-update)
  (let* ((subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct)))
	 (res    '()))
    (for-each
     (lambda (subdb)
       (let* ((mtdb   (dbr:subdb-mtdb subdb))
	      (tmpdb  (db:get-subdb dbstruct run-id))
	      (refndb (dbr:subdb-refndb subdb))
	      (newres (db:sync-tables (db:sync-all-tables-list (db:get-keys dbstruct)) last-update tmpdb refndb mtdb)))
	 ;; (stack-push! (dbr:subdb-dbstack subdb) tmpdb)
	 ;; BUG: verify this is really needed
	 (dbfile:add-dbdat dbstruct run-id tmpdb)
	 (set! res (cons newres res))))







|







1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
;; Sync all changed db's
;;
(define (db:tmp->megatest.db-sync dbstruct run-id last-update)
  (let* ((subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct)))
	 (res    '()))
    (for-each
     (lambda (subdb)
       (let* ((mtdb   (dbr:subdb-mtdbdat subdb))
	      (tmpdb  (db:get-subdb dbstruct run-id))
	      (refndb (dbr:subdb-refndb subdb))
	      (newres (db:sync-tables (db:sync-all-tables-list (db:get-keys dbstruct)) last-update tmpdb refndb mtdb)))
	 ;; (stack-push! (dbr:subdb-dbstack subdb) tmpdb)
	 ;; BUG: verify this is really needed
	 (dbfile:add-dbdat dbstruct run-id tmpdb)
	 (set! res (cons newres res))))
1537
1538
1539
1540
1541
1542
1543
1544
1545

1546

1547
1548
1549
1550
1551
1552
1553
      (if (common:low-noise-print 30 "sync new to old")
          (if sync-needed
              (debug:print-info 0 *default-log-port* "Sync of " res " records from newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
              (debug:print-info 0 *default-log-port* "No sync needed, last updated " (- start-time last-update) " seconds ago")))
      res))


(define (db:initialize-main-db db)
  (when (not *configinfo*)

           (launch:setup)) ;; added because Elena was getting stack dump because *configinfo* below was #f.

  (let* ((configdat (car *configinfo*))  ;; tut tut, global warning...
	 (keys     (keys:config-get-fields configdat))
	 (havekeys (> (length keys) 0))
	 (keystr   (keys->keystr keys))
	 (fieldstr (keys:make-key/field-string configdat))
	 #;(db       (dbr:dbdat-dbh dbdat)))
    (for-each (lambda (key)







|

>
|
>







1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
      (if (common:low-noise-print 30 "sync new to old")
          (if sync-needed
              (debug:print-info 0 *default-log-port* "Sync of " res " records from newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
              (debug:print-info 0 *default-log-port* "No sync needed, last updated " (- start-time last-update) " seconds ago")))
      res))


(define (db:initialize-main-db db #!key (launch-setup #f))
  (when (not *configinfo*)
    (if launch-setup
	(launch-setup) ;; added because Elena was getting stack dump because *configinfo* below was #f.
	(assert #f "db:initialize-main-db called and needs launch:setup but was not given it")))
  (let* ((configdat (car *configinfo*))  ;; tut tut, global warning...
	 (keys     (keys:config-get-fields configdat))
	 (havekeys (> (length keys) 0))
	 (keystr   (keys->keystr keys))
	 (fieldstr (keys:make-key/field-string configdat))
	 #;(db       (dbr:dbdat-dbh dbdat)))
    (for-each (lambda (key)
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
	(lambda (val)
	  (set! res val))
	db
	(conc "SELECT " key " FROM runs WHERE id=?;")
	run-id)
       res))))

;; keys list to key1,key2,key3 ...
(define (runs:get-std-run-fields keys remfields)
  (let* ((header    (append keys remfields))
	 (keystr    (conc (keys->keystr keys) ","
			  (string-intersperse remfields ","))))
    (list keystr header)))

;; make a query (fieldname like 'patt1' OR fieldname 
(define (db:patt->like fieldname pattstr #!key (comparator " OR "))
  (let ((patts (if (string? pattstr)
		   (string-split pattstr ",")
		   '("%"))))
    (string-intersperse (map (lambda (patt)
			       (let ((wildtype (if (substring-index "%" patt) "LIKE" "GLOB")))
				 (conc fieldname " " wildtype " '" patt "'")))
			     (if (null? patts)
				 '("")
				 patts))
			comparator)))


;; register a test run with the db, this accesses the main.db and does NOT
;; use server api
;;
(define (db:register-run dbstruct keyvals runname state status user contour-in)
  (let* ((keys      (map car keyvals))
	 (keystr    (keys->keystr keys))







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







2146
2147
2148
2149
2150
2151
2152




















2153
2154
2155
2156
2157
2158
2159
	(lambda (val)
	  (set! res val))
	db
	(conc "SELECT " key " FROM runs WHERE id=?;")
	run-id)
       res))))






















;; register a test run with the db, this accesses the main.db and does NOT
;; use server api
;;
(define (db:register-run dbstruct keyvals runname state status user contour-in)
  (let* ((keys      (map car keyvals))
	 (keystr    (keys->keystr keys))
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
	   (keystr   (string-intersperse keys ","))
	   (key?str  (string-intersperse (make-list (length targvals) "?") ","))
	   (qrystr   (conc "INSERT INTO runs (id,runname,"keystr") VALUES (?,?,"key?str")"))
	   (get-var  (lambda (db qrystr)
		       (let* ((res #f))
			 (sqlite3:for-each-row
			  (lambda row
			    (set res (car row)))
			  db qrystr run-id runname)
			 res))))
      (if (null? runs)
        (begin
	  (db:create-initial-run-record dbstruct run-id runname target)
        )
      )







|







2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
	   (keystr   (string-intersperse keys ","))
	   (key?str  (string-intersperse (make-list (length targvals) "?") ","))
	   (qrystr   (conc "INSERT INTO runs (id,runname,"keystr") VALUES (?,?,"key?str")"))
	   (get-var  (lambda (db qrystr)
		       (let* ((res #f))
			 (sqlite3:for-each-row
			  (lambda row
			    (set! res (car row)))
			  db qrystr run-id runname)
			 res))))
      (if (null? runs)
        (begin
	  (db:create-initial-run-record dbstruct run-id runname target)
        )
      )
3792
3793
3794
3795
3796
3797
3798




3799
3800
3801
3802
3803
3804
3805
;; foo,bla,   1.2,  1.9, <
;; foo,bal,   1.2,  1.2, <   ,     ,Check for overload
;; foo,alb,   1.2,  1.2, <=  , Amps,This is the high power circuit test
;; foo,abl,   1.2,  1.3, 0.1
;; foo,bra,   1.2, pass, silly stuff
;; faz,bar,    10,  8mA,     ,     ,"this is a comment"
;; EOF





(define (db:csv->test-data dbstruct run-id test-id csvdata)
  (debug:print 4 *default-log-port* "test-id " test-id ", csvdata: " csvdata)
  (db:with-db
   dbstruct #f #t
   (lambda (dbdat db)
     (let* ((csvlist (csv->list (make-csv-reader







>
>
>
>







3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
;; foo,bla,   1.2,  1.9, <
;; foo,bal,   1.2,  1.2, <   ,     ,Check for overload
;; foo,alb,   1.2,  1.2, <=  , Amps,This is the high power circuit test
;; foo,abl,   1.2,  1.3, 0.1
;; foo,bra,   1.2, pass, silly stuff
;; faz,bar,    10,  8mA,     ,     ,"this is a comment"
;; EOF

(define (tdb:get-prev-tol-for-test tdb test-id category variable)
  ;; Finish me?
  (values #f #f #f))

(define (db:csv->test-data dbstruct run-id test-id csvdata)
  (debug:print 4 *default-log-port* "test-id " test-id ", csvdata: " csvdata)
  (db:with-db
   dbstruct #f #t
   (lambda (dbdat db)
     (let* ((csvlist (csv->list (make-csv-reader
4996
4997
4998
4999
5000
5001
5002
5003
5004
5005
5006
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028
5029
5030
5031
5032
5033
5034
5035
5036
5037
5038
5039
5040
5041
5042
5043
5044
5045
5046
5047
5048
5049
5050
5051
5052
5053
5054
5055
5056
5057
5058
5059
5060
5061
5062
5063
5064
5065
5066
5067
5068
5069
5070
5071
5072
5073
5074
5075
5076
5077
5078
5079
5080
5081
5082
5083
5084
5085
5086
5087
5088
5089
5090
5091
5092
5093
5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
5104
5105
5106
5107
5108
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
5119
5120
5121
5122
5123
5124
5125
5126
5127
5128
5129
5130
5131
5132
5133
5134
5135
5136
5137
5138
5139
5140
5141
5142
5143
5144
5145
5146
5147
5148
5149
5150
5151
5152
5153
5154
5155
5156
5157
5158
5159
5160
5161
5162
5163
5164
5165
5166
5167
5168
5169
5170
5171
5172
5173
5174
5175
5176
  (let* ((backcons        (lambda (lst item)(cons item lst)))
         (all_run_ids     (db:with-db dbstruct #f #f 
                            (lambda (dbdat db)
                              (sqlite3:fold-row backcons '() db "SELECT id FROM runs")))))

all_run_ids))

;;======================================================================
;; Extract ods file from the db
;;======================================================================

;; NOT REWRITTEN YET!!!!!

;; runspatt is a comma delimited list of run patterns
;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. )
(define (db:extract-ods-file dbstruct outputfile keypatt-alist runspatt pathmod)
  (assert #f "FATAL: call to db:extract-ods-file which is not ported yet.")
  (let* ((keysstr  (string-intersperse (map car keypatt-alist) ","))
	 (keyqry   (string-intersperse (map (lambda (p)(conc (car p) " LIKE ? ")) keypatt-alist) " AND "))
	 (numkeys  (length keypatt-alist))
	 (test-ids '())
	 (dbdat    (db:get-subdb dbstruct))
	 (db       (dbr:dbdat-dbh dbdat))
	 (windows  (and pathmod (substring-index "\\" pathmod)))
	 (tempdir  (conc "/tmp/" (current-user-name) "/" runspatt "_" (random 10000) "_" (current-process-id)))
	 (runsheader (append (list "Run Id" "Runname") ; 0 1
			     (map car keypatt-alist)   ; + N = length keypatt-alist
			     (list "Testname"          ; 2
				   "Item Path"         ; 3 
				   "Description"       ; 4 
				   "State"             ; 5 
				   "Status"            ; 6  
				   "Final Log"         ; 7 
				   "Run Duration"      ; 8 
				   "When Run"          ; 9 
				   "Tags"              ; 10
				   "Run Owner"         ; 11
				   "Comment"           ; 12
				   "Author"            ; 13
				   "Test Owner"        ; 14
				   "Reviewed"          ; 15
				   "Diskfree"          ; 16
				   "Uname"             ; 17
				   "Rundir"            ; 18
				   "Host"              ; 19
				   "Cpu Load"          ; 20
				   )))
	 (results (list runsheader))			 
	 (testdata-header (list "Run Id" "Testname" "Item Path" "Category" "Variable" "Value" "Expected" "Tol" "Units" "Status" "Comment"))
	 (mainqry (conc "SELECT
              t.testname,r.id,runname," keysstr ",t.testname,
              t.item_path,tm.description,t.state,t.status,
              final_logf,run_duration, 
              strftime('%m/%d/%Y %H:%M:%S',datetime(t.event_time,'unixepoch'),'localtime'),
              tm.tags,r.owner,t.comment,
              author,
              tm.owner,reviewed,
              diskfree,uname,rundir,
              host,cpuload
            FROM tests AS t JOIN runs AS r ON t.run_id=r.id JOIN test_meta AS tm ON tm.testname=t.testname
            WHERE runname LIKE ? AND " keyqry ";")))
    (debug:print 2 *default-log-port* "Using " tempdir " for constructing the ods file. keyqry: " keyqry " keystr: " keysstr " with keys: " (map cadr keypatt-alist)
		 "\n      mainqry: " mainqry)
    ;; "Expected Value"
    ;; "Value Found"
    ;; "Tolerance"
    (apply sqlite3:for-each-row
	   (lambda (test-id . b)
	     (set! test-ids (cons test-id test-ids))   ;; test-id is now testname
	     (set! results (append results ;; note, drop the test-id
				   (list
				    (if pathmod
					(let* ((vb        (apply vector b))
					       (keyvals   (let loop ((i    0)
								     (res '()))
							    (if (>= i numkeys)
								res
								(loop (+ i 1)
								      (append res (list (vector-ref vb (+ i 2))))))))
					       (runname   (vector-ref vb 1))
					       (testname  (vector-ref vb (+  2 numkeys)))
					       (item-path (vector-ref vb (+  3 numkeys)))
					       (final-log (vector-ref vb (+  7 numkeys)))
					       (run-dir   (vector-ref vb (+ 18 numkeys)))
					       (log-fpath (conc run-dir "/"  final-log))) ;; (string-intersperse keyvals "/") "/" testname "/" item-path "/"
					  (debug:print 4 *default-log-port* "log: " log-fpath " exists: " (common:file-exists? log-fpath))
					  (vector-set! vb (+ 7 numkeys) (if (common:file-exists? log-fpath)
									    (let ((newpath (conc pathmod "/"
												 (string-intersperse keyvals "/")
												 "/" runname "/" testname "/"
												 (if (string=? item-path "") "" (conc "/" item-path))
												 final-log)))
									      ;; for now throw away newpath and use the log-fpath conc'd with pathmod
									      (set! newpath (conc pathmod log-fpath))
									      (if windows (string-translate newpath "/" "\\") newpath))
									    (if (debug:debug-mode 1)
										(conc final-log " not-found")
										"")))
					  (vector->list vb))
					b)))))
	   db
	   mainqry
	   runspatt (map cadr keypatt-alist))
    (debug:print 2 *default-log-port* "Found " (length test-ids) " records")
    (set! results (list (cons "Runs" results)))
    ;; now, for each test, collect the test_data info and add a new sheet
    (for-each
     (lambda (test-id)
       (let ((test-data (list testdata-header))
	     (curr-test-name #f))
	 (sqlite3:for-each-row
	  (lambda (run-id testname item-path category variable value expected tol units status comment)
	    (set! curr-test-name testname)
	    (set! test-data (append test-data (list (list run-id testname item-path category variable value expected tol units status comment)))))
	  db 
	  ;; "SELECT run_id,testname,item_path,category,variable,td.value AS value,expected,tol,units,td.status AS status,td.comment AS comment FROM test_data AS td INNER JOIN tests ON tests.id=td.test_id WHERE test_id=?;"
	  "SELECT run_id,testname,item_path,category,variable,td.value AS value,td.expected,td.tol,td.units,td.status AS status,td.comment AS comment FROM test_data AS td INNER JOIN tests ON tests.id=td.test_id WHERE testname=?;"
	  test-id)
	 (if curr-test-name
	     (set! results (append results (list (cons curr-test-name test-data)))))
	 ))
     (sort (delete-duplicates test-ids) string<=))
    (system (conc "mkdir -p " tempdir))
    ;; (pp results)
    (ods:list->ods 
     tempdir
     (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path?
	 outputfile
	 (begin
	   (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory")
	   (conc (current-directory) "/" outputfile)))
     results)
    ;; brutal clean up
    (dbfile:add-dbdat dbstruct #f dbdat)
    (system "rm -rf tempdir")))

;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%")

;;======================================================================
;; moving watch dogs here due to dependencies
;;======================================================================

;;======================================================================
;; 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)))
    (debug:print-info 0 *default-log-port* "Read-only periodic sync thread started.")
    (let loop ((last-sync-time 0))
      (debug:print-info 13 *default-log-port* "loop top tmp-mtpath="tmp-mtpath" golden-mtpath="golden-mtpath)
      (let* ((duration-since-last-sync (- (current-seconds) last-sync-time)))
        (debug:print-info 13 *default-log-port* "duration-since-last-sync="duration-since-last-sync)
        (if (and (not *time-to-exit*)
                 (< duration-since-last-sync sync-cool-off-duration))
            (thread-sleep! (- sync-cool-off-duration duration-since-last-sync)))
        (if (not *time-to-exit*)
            (let ((golden-mtdb-mtime (file-modification-time golden-mtpath))
                  (tmp-mtdb-mtime    (file-modification-time tmp-mtpath)))
	      (if (> golden-mtdb-mtime tmp-mtdb-mtime)
		  (if (< golden-mtdb-mtime (- (current-seconds) 3)) ;; file has NOT been touched in past three seconds, this way multiple servers won't fight to sync back
		      (let ((res (db:multi-db-sync dbstruct 'old2new)))
			(debug:print-info 13 *default-log-port* "rosync called, " res " records transferred."))))
              (loop (current-seconds)))
            #t)))
    (debug:print-info 0 *default-log-port* "Exiting readonly-watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" mtpath="golden-mtpath)))


;; Get a lock from the no-sync-db for the from-db, then copy the from-db to the to-db, otherwise return #f

(define (db:lock-and-sync no-sync-db from-db to-db)
  (assert (not *db-sync-in-progress*) "FATAL: db:lock-and-sync called while a sync is in progress.")
  (let* ((lockdat  (db:no-sync-get-lock no-sync-db from-db))
	 (gotlock  (car lockdat))







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




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







4916
4917
4918
4919
4920
4921
4922



































































































































4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
4949
4950
4951
4952
4953
4954
4955
4956
4957
4958
4959
4960
4961
4962
4963
4964
4965
  (let* ((backcons        (lambda (lst item)(cons item lst)))
         (all_run_ids     (db:with-db dbstruct #f #f 
                            (lambda (dbdat db)
                              (sqlite3:fold-row backcons '() db "SELECT id FROM runs")))))

all_run_ids))




































































































































;;======================================================================
;; moving watch dogs here due to dependencies
;;======================================================================

;; =not-used= ;;======================================================================
;; =not-used= ;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp
;; =not-used= ;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server)
;; =not-used= ;;
;; =not-used= (define (common:readonly-watchdog dbstruct)
;; =not-used=   (thread-sleep! 0.05) ;; delay for startup
;; =not-used=   (debug:print-info 13 *default-log-port* "common:readonly-watchdog entered.")
;; =not-used=   ;; sync megatest.db to /tmp/.../megatst.db
;; =not-used=   (let* ((sync-cool-off-duration   3)
;; =not-used=         (golden-mtdb     (dbr:dbstruct-mtdb dbstruct))
;; =not-used=         (golden-mtpath   (db:dbdat-get-path golden-mtdb))
;; =not-used=         (tmp-mtdb        (dbr:dbstruct-tmpdb dbstruct))
;; =not-used=         (tmp-mtpath      (db:dbdat-get-path tmp-mtdb)))
;; =not-used=     (debug:print-info 0 *default-log-port* "Read-only periodic sync thread started.")
;; =not-used=     (let loop ((last-sync-time 0))
;; =not-used=       (debug:print-info 13 *default-log-port* "loop top tmp-mtpath="tmp-mtpath" golden-mtpath="golden-mtpath)
;; =not-used=       (let* ((duration-since-last-sync (- (current-seconds) last-sync-time)))
;; =not-used=         (debug:print-info 13 *default-log-port* "duration-since-last-sync="duration-since-last-sync)
;; =not-used=         (if (and (not *time-to-exit*)
;; =not-used=                  (< duration-since-last-sync sync-cool-off-duration))
;; =not-used=             (thread-sleep! (- sync-cool-off-duration duration-since-last-sync)))
;; =not-used=         (if (not *time-to-exit*)
;; =not-used=             (let ((golden-mtdb-mtime (file-modification-time golden-mtpath))
;; =not-used=                   (tmp-mtdb-mtime    (file-modification-time tmp-mtpath)))
;; =not-used= 	      (if (> golden-mtdb-mtime tmp-mtdb-mtime)
;; =not-used= 		  (if (< golden-mtdb-mtime (- (current-seconds) 3)) ;; file has NOT been touched in past three seconds, this way multiple servers won't fight to sync back
;; =not-used= 		      (let ((res (db:multi-db-sync dbstruct 'old2new)))
;; =not-used= 			(debug:print-info 13 *default-log-port* "rosync called, " res " records transferred."))))
;; =not-used=               (loop (current-seconds)))
;; =not-used=             #t)))
;; =not-used=     (debug:print-info 0 *default-log-port* "Exiting readonly-watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" mtpath="golden-mtpath)))
;; =not-used= 

;; Get a lock from the no-sync-db for the from-db, then copy the from-db to the to-db, otherwise return #f

(define (db:lock-and-sync no-sync-db from-db to-db)
  (assert (not *db-sync-in-progress*) "FATAL: db:lock-and-sync called while a sync is in progress.")
  (let* ((lockdat  (db:no-sync-get-lock no-sync-db from-db))
	 (gotlock  (car lockdat))
5223
5224
5225
5226
5227
5228
5229
5230
5231
5232
5233
5234
5235
5236
5237
5238
5239
5240
5241
5242
5243
5244
5245
5246
5247
5248
5249
5250
5251
5252
5253
5254
5255
5256
5257
5258
5259
5260
5261
5262
5263
5264
5265
5266
5267
5268
5269
5270
5271
5272
5273
5274
5275
5276
5277
5278
5279
5280
5281
5282
5283
5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
5297
5298
5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
5311
5312
5313
5314
5315
5316
5317
5318
5319
5320
5321
5322
5323
5324
5325
5326
5327
5328
5329
5330
5331
5332
5333
5334
5335
5336
5337
5338
5339
5340
5341
5342
5343
5344
5345
5346
5347
5348
5349
5350
5351
5352
5353
5354

5355
5356
5357
5358
5359
5360
5361
5362
5363
5364
5365
5366

5367
5368
5369
5370
5371
5372
5373
5374
5375
5376
5377
5378
5379
5380
5381
5382
5383
5384
5385
5386
5387
5388
5389
5390
5391
5392
5393
5394
5395
5396
5397
5398
5399
5400
5401
5402
5403
5404
5405
5406
5407
5408
5409
	       (debug:print-info 0 *default-log-port* "sync copy file: " fname", delta: " (- time1 time2) " seconds")
	       (db:lock-and-sync no-sync-db file fulln)
	       (hash-table-set! sync-durations (conc fname".db") (- (current-milliseconds) start-time)))
	     #;(debug:print-info 0 *default-log-port* "skipping sync..."))))
     dbfiles)
    (hash-table->alist sync-durations)))

;; straight forward copy based sync
;;  1. for each .db fil
;;  2. next if file changed since last sync cycle
;;  2. next if time delta /tmp file to MTRA less than 3 seconds
;;  3. get a lock for the file in nosyncdb
;;  4. copy the file
;;  5. when copy is done release the lock
;;
;;  DONE
(define (server:writable-watchdog-copysync 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))     ;; last time through the sync loop
 	(no-sync-db         (db:open-no-sync-db))
 	(sync-duration      0)  ;; run time of the sync in milliseconds
	(tmp-area           (common:make-tmpdir-name *toppath* "")))
    ;; Sync moved to http-transport keep-running loop
    (debug:print-info 2 *default-log-port* "Periodic copy-based sync thread started. syncer is copy-sync, tmp-area is " tmp-area)
    (debug:print-info 3 *default-log-port* "watchdog starting. syncer is copy-sync pid="(current-process-id));;  " this-wd-num="this-wd-num)
    
    (if (and legacy-sync (not *time-to-exit*))
 	(begin
 	  (debug:print-info 0 *default-log-port* "Server running, periodic copy-based sync started.")
	  (let loop ()

	    ;; run the sync and print out durations
	    (debug:print-info 0 *default-log-port* "Sync durations: "(db:run-lock-and-sync no-sync-db))
	    ;; keep going unless time to exit
	    ;;
	    (if (not *time-to-exit*)
		(let delay-loop ((count 0))
		  ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
		  
		  (if (and (not *time-to-exit*)
			   (< count 6)) ;; was 11, changing to 4. 
		      (begin
			(thread-sleep! 1)
			(delay-loop (+ count 1))))
		  (if (not *time-to-exit*) (loop))))
	    
	    ;; ==> 	       ;; time to exit, close the no-sync db here
	    ;; ==> 	       (db:no-sync-close-db no-sync-db stmt-cache)
	    (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)
  ;; This is awful complex and convoluted. Plan to redo?
  ;; for now ... skip it.
 
  (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   #f) ;; (dbr:dbstruct-stmt-cache dbstruct))
 	(sync-duration 0) ;; run time of the sync in milliseconds
       (subdbs       (hash-table-values (dbr:dbstruct-subdbs dbstruct))))
   (debug:print-info 2 *default-log-port* "Periodic sync thread started.")
   (debug:print-info 3 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id)  );;  " this-wd-num="this-wd-num)
   
   (if (and legacy-sync (not *time-to-exit*))
 	(begin
 	  (debug:print-info 0 *default-log-port* "Server running, periodic sync started.")
	  (let loop ()
 	    ;; sync for filesystem local db writes
 	    ;;
 	    (mutex-lock! *db-multi-sync-mutex*)
 	       (let* ((start-file (conc tmp-area "/.start-sync"))
 		      (end-file   (conc tmp-area "/.end-sync"))
 			      
 		      (need-sync        (>= *db-last-access* *db-last-sync*)) ;; no sync since last write
 		      (sync-in-progress *db-sync-in-progress*)
 		      (min-intersync-delay (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 5))
 		      (should-sync      (and (not *time-to-exit*)
 					     (> (- (current-seconds) *db-last-sync*) min-intersync-delay))) ;; sync every five seconds minimum, deprecated logic, can probably be removed
 		      (start-time       (current-seconds))
 		      (cpu-load-adj     (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f)))
 		      (mt-mod-time      (file-modification-time mtpath))
 		      (last-sync-start  (if (common:file-exists? start-file)
 					    (file-modification-time start-file)
 					    0))
 		      (last-sync-end    (if (common:file-exists? end-file)
 					    (file-modification-time end-file)
 					    10))
 		      (sync-period      (+ 3 (* cpu-load-adj 30))) ;; as adjusted load increases increase the sync period
 		      (recently-synced  (and (< (- start-time mt-mod-time) sync-period) ;; not useful if sync didn't modify megatest.db!
 					     (< mt-mod-time last-sync-start)))
 		      (sync-done        (<= last-sync-start last-sync-end))
 		      (sync-stale       (> start-time (+ last-sync-start sync-stale-seconds)))
 		      (will-sync        (and (not *time-to-exit*)       ;; do not start a sync if we are in the process of exiting
 					     (or need-sync should-sync)
 					     (or sync-done sync-stale)
 					     (not sync-in-progress)
 					     (not recently-synced))))
 		 (debug:print-info 13 *default-log-port* "WD writable-watchdog top of loop.  need-sync="need-sync" sync-in-progress=" sync-in-progress
 				   " should-sync="should-sync" start-time="start-time" mt-mod-time="mt-mod-time" recently-synced="recently-synced" will-sync="will-sync
 				   " sync-done=" sync-done " sync-period=" sync-period)
 		 (if (and (> sync-period 5)
 			  (common:low-noise-print 30 "sync-period"))
 		     (debug:print-info 0 *default-log-port* "Increased sync period due to long sync times, sync took: " sync-period " seconds."))
 		 ;; (if recently-synced (debug:print-info 0 *default-log-port* "Skipping sync due to recently-synced flag=" recently-synced))
 		 ;; (debug:print-info 0 *default-log-port* "need-sync: " need-sync " sync-in-progress: " sync-in-progress " should-sync: " should-sync " will-sync: " will-sync)
 		 (if will-sync (set! *db-sync-in-progress* #t))
 		 (mutex-unlock! *db-multi-sync-mutex*)
 		 (if will-sync
 		     (let (;; (max-sync-duration  (configf:lookup-number *configdat* "server" "max-sync-duration")) ;; KEEPING THIS AVAILABLE BUT SHOULD NOT USE, I'M PRETTY SURE IT DOES NOT WORK!
 			   (sync-start         (current-milliseconds)))
 		       (with-output-to-file start-file (lambda ()(print (current-process-id))))
 		       
 		       ;; put lock here
 		       
 		       ;; (if (or (not max-sync-duration)
 		       ;;        (< sync-duration max-sync-duration)) ;; NOTE: db:sync-to-megatest.db keeps track of time of last sync and syncs incrementally
 
 		      ;;
 		     
 		       (for-each
 			(lambda (subdb)
 			  (let* (;;(dbstruct (db:setup))
 				 (mtdb       (dbr:subdb-mtdb subdb))

 				 (mtpath     (db:dbdat-get-path mtdb))
 				 (tmp-area   (common:make-tmpdir-name *toppath* ""))
 				 (res        (db:sync-to-megatest.db dbstruct no-sync-db: no-sync-db))) ;; did we sync any data? If so need to set the db touched flag to keep the server alive
 			    (set! sync-duration (- (current-milliseconds) sync-start))
 			    (if (> res 0) ;; some records were transferred, keep the db alive
 				(begin
 				  (mutex-lock! *heartbeat-mutex*)
 				  (set! *db-last-access* (current-seconds))
 				  (mutex-unlock! *heartbeat-mutex*)
 				  (debug:print-info 0 *default-log-port* "sync called, " res " records transferred."))
 				(debug:print-info 2 *default-log-port* "sync called but zero records transferred")))
 			  )

 			subdbs)))
 		 
 		 (if will-sync
 		     (begin
 		       (mutex-lock! *db-multi-sync-mutex*)
 		       (set! *db-sync-in-progress* #f)
 		       (set! *db-last-sync* start-time)
 		       (with-output-to-file end-file (lambda ()(print (current-process-id))))
 		       
 		       ;; release lock here
 		       
 		       (mutex-unlock! *db-multi-sync-mutex*)))
 		 (if (and debug-mode
 			  (> (- start-time last-time) 60))
 		     (begin
 		       (set! last-time start-time)
 		       (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*))))))
 	       
	       ;; keep going unless time to exit
	       ;;
	       (if (not *time-to-exit*)
		   (let delay-loop ((count 0))
		     ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
		     
		     (if (and (not *time-to-exit*)
			      (< count 6)) ;; was 11, changing to 4. 
			 (begin
			   (thread-sleep! 1)
			   (delay-loop (+ count 1))))
		     (if (not *time-to-exit*) (loop))))
	       
;; 	       ;; time to exit, close the no-sync db here
;; 	       (db:no-sync-close-db no-sync-db stmt-cache)
	       (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 (std-exit-procedure)
  ;;(common:telemetry-log-close)
  (on-exit (lambda () 0)) ;; why is this here?
  ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*)
  (let ((no-hurry  (if *time-to-exit* ;; hurry up
		       #f







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


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







5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028
5029
5030
5031
5032
5033
5034
5035
5036
5037
5038
5039
5040
5041
5042
5043
5044
5045
5046
5047
5048
5049
5050
5051
5052
5053
5054
5055
5056
5057
5058
5059
5060
5061
5062
5063
5064
5065
5066
5067
5068
5069
5070
5071
5072
5073
5074
5075
5076
5077
5078
5079
5080
5081
5082
5083
5084
5085
5086
5087
5088
5089
5090
5091
5092
5093
5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
5104
5105
5106
5107
5108
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
5119
5120
5121
5122
5123
5124
5125
5126
5127
5128
5129
5130
5131
5132
5133
5134
5135
5136
5137
5138
5139
5140
5141
5142
5143
5144
5145
5146
5147
5148
5149
5150
5151
5152
5153
5154
5155

5156
5157
5158
5159
5160
5161
5162
5163
5164
5165
5166
5167
5168
5169
5170
5171
5172
5173
5174
5175
5176
5177
5178
5179
5180
5181
5182
5183
5184
5185
5186
5187
5188
5189
5190
5191
5192
5193
5194
5195
5196
5197
5198
5199
	       (debug:print-info 0 *default-log-port* "sync copy file: " fname", delta: " (- time1 time2) " seconds")
	       (db:lock-and-sync no-sync-db file fulln)
	       (hash-table-set! sync-durations (conc fname".db") (- (current-milliseconds) start-time)))
	     #;(debug:print-info 0 *default-log-port* "skipping sync..."))))
     dbfiles)
    (hash-table->alist sync-durations)))

;; =not-used= ;; straight forward copy based sync
;; =not-used= ;;  1. for each .db fil
;; =not-used= ;;  2. next if file changed since last sync cycle
;; =not-used= ;;  2. next if time delta /tmp file to MTRA less than 3 seconds
;; =not-used= ;;  3. get a lock for the file in nosyncdb
;; =not-used= ;;  4. copy the file
;; =not-used= ;;  5. when copy is done release the lock
;; =not-used= ;;
;; =not-used= ;;  DONE
;; =not-used= (define (server:writable-watchdog-copysync dbstruct)
;; =not-used=   (thread-sleep! 0.05) ;; delay for startup
;; =not-used=   (let ((legacy-sync        (common:run-sync?))
;; =not-used= 	(sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300))
;; =not-used=  	(debug-mode         (debug:debug-mode 1))
;; =not-used=  	(last-time          (current-seconds))     ;; last time through the sync loop
;; =not-used=  	(no-sync-db         (db:open-no-sync-db))
;; =not-used=  	(sync-duration      0)  ;; run time of the sync in milliseconds
;; =not-used= 	(tmp-area           (common:make-tmpdir-name *toppath* "")))
;; =not-used=     ;; Sync moved to http-transport keep-running loop
;; =not-used=     (debug:print-info 2 *default-log-port* "Periodic copy-based sync thread started. syncer is copy-sync, tmp-area is " tmp-area)
;; =not-used=     (debug:print-info 3 *default-log-port* "watchdog starting. syncer is copy-sync pid="(current-process-id));;  " this-wd-num="this-wd-num)
;; =not-used=     
;; =not-used=     (if (and legacy-sync (not *time-to-exit*))
;; =not-used=  	(begin
;; =not-used=  	  (debug:print-info 0 *default-log-port* "Server running, periodic copy-based sync started.")
;; =not-used= 	  (let loop ()
;; =not-used= 
;; =not-used= 	    ;; run the sync and print out durations
;; =not-used= 	    (debug:print-info 0 *default-log-port* "Sync durations: "(db:run-lock-and-sync no-sync-db))
;; =not-used= 	    ;; keep going unless time to exit
;; =not-used= 	    ;;
;; =not-used= 	    (if (not *time-to-exit*)
;; =not-used= 		(let delay-loop ((count 0))
;; =not-used= 		  ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
;; =not-used= 		  
;; =not-used= 		  (if (and (not *time-to-exit*)
;; =not-used= 			   (< count 6)) ;; was 11, changing to 4. 
;; =not-used= 		      (begin
;; =not-used= 			(thread-sleep! 1)
;; =not-used= 			(delay-loop (+ count 1))))
;; =not-used= 		  (if (not *time-to-exit*) (loop))))
;; =not-used= 	    
;; =not-used= 	    ;; ==> 	       ;; time to exit, close the no-sync db here
;; =not-used= 	    ;; ==> 	       (db:no-sync-close-db no-sync-db stmt-cache)
;; =not-used= 	    (if (common:low-noise-print 30)
;; =not-used= 		(debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = "
;; =not-used= 				  *time-to-exit*" pid="(current-process-id) )))))))


;; =not-used= (define (server:writable-watchdog-deltasync dbstruct)
;; =not-used=   ;; This is awful complex and convoluted. Plan to redo?
;; =not-used=   ;; for now ... skip it.
;; =not-used=  
;; =not-used=   (thread-sleep! 0.05) ;; delay for startup
;; =not-used=   (let ((legacy-sync  (common:run-sync?)))
;; =not-used=        (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300))
;; =not-used=  	(debug-mode   (debug:debug-mode 1))
;; =not-used=  	(last-time    (current-seconds))
;; =not-used=  	(no-sync-db   (db:open-no-sync-db))
;; =not-used=  	(stmt-cache   #f) ;; (dbr:dbstruct-stmt-cache dbstruct))
;; =not-used=  	(sync-duration 0) ;; run time of the sync in milliseconds
;; =not-used=        (subdbs       (hash-table-values (dbr:dbstruct-subdbs dbstruct))))
;; =not-used=    (debug:print-info 2 *default-log-port* "Periodic sync thread started.")
;; =not-used=    (debug:print-info 3 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id)  );;  " this-wd-num="this-wd-num)
;; =not-used=    
;; =not-used=    (if (and legacy-sync (not *time-to-exit*))
;; =not-used=  	(begin
;; =not-used=  	  (debug:print-info 0 *default-log-port* "Server running, periodic sync started.")
;; =not-used= 	  (let loop ()
;; =not-used=  	    ;; sync for filesystem local db writes
;; =not-used=  	    ;;
;; =not-used=  	    (mutex-lock! *db-multi-sync-mutex*)
;; =not-used=  	       (let* ((start-file (conc tmp-area "/.start-sync"))
;; =not-used=  		      (end-file   (conc tmp-area "/.end-sync"))
;; =not-used=  			      
;; =not-used=  		      (need-sync        (>= *db-last-access* *db-last-sync*)) ;; no sync since last write
;; =not-used=  		      (sync-in-progress *db-sync-in-progress*)
;; =not-used=  		      (min-intersync-delay (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 5))
;; =not-used=  		      (should-sync      (and (not *time-to-exit*)
;; =not-used=  					     (> (- (current-seconds) *db-last-sync*) min-intersync-delay))) ;; sync every five seconds minimum, deprecated logic, can probably be removed
;; =not-used=  		      (start-time       (current-seconds))
;; =not-used=  		      (cpu-load-adj     (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f)))
;; =not-used=  		      (mt-mod-time      (file-modification-time mtpath))
;; =not-used=  		      (last-sync-start  (if (common:file-exists? start-file)
;; =not-used=  					    (file-modification-time start-file)
;; =not-used=  					    0))
;; =not-used=  		      (last-sync-end    (if (common:file-exists? end-file)
;; =not-used=  					    (file-modification-time end-file)
;; =not-used=  					    10))
;; =not-used=  		      (sync-period      (+ 3 (* cpu-load-adj 30))) ;; as adjusted load increases increase the sync period
;; =not-used=  		      (recently-synced  (and (< (- start-time mt-mod-time) sync-period) ;; not useful if sync didn't modify megatest.db!
;; =not-used=  					     (< mt-mod-time last-sync-start)))
;; =not-used=  		      (sync-done        (<= last-sync-start last-sync-end))
;; =not-used=  		      (sync-stale       (> start-time (+ last-sync-start sync-stale-seconds)))
;; =not-used=  		      (will-sync        (and (not *time-to-exit*)       ;; do not start a sync if we are in the process of exiting
;; =not-used=  					     (or need-sync should-sync)
;; =not-used=  					     (or sync-done sync-stale)
;; =not-used=  					     (not sync-in-progress)
;; =not-used=  					     (not recently-synced))))
;; =not-used=  		 (debug:print-info 13 *default-log-port* "WD writable-watchdog top of loop.  need-sync="need-sync" sync-in-progress=" sync-in-progress
;; =not-used=  				   " should-sync="should-sync" start-time="start-time" mt-mod-time="mt-mod-time" recently-synced="recently-synced" will-sync="will-sync
;; =not-used=  				   " sync-done=" sync-done " sync-period=" sync-period)
;; =not-used=  		 (if (and (> sync-period 5)
;; =not-used=  			  (common:low-noise-print 30 "sync-period"))
;; =not-used=  		     (debug:print-info 0 *default-log-port* "Increased sync period due to long sync times, sync took: " sync-period " seconds."))
;; =not-used=  		 ;; (if recently-synced (debug:print-info 0 *default-log-port* "Skipping sync due to recently-synced flag=" recently-synced))
;; =not-used=  		 ;; (debug:print-info 0 *default-log-port* "need-sync: " need-sync " sync-in-progress: " sync-in-progress " should-sync: " should-sync " will-sync: " will-sync)
;; =not-used=  		 (if will-sync (set! *db-sync-in-progress* #t))
;; =not-used=  		 (mutex-unlock! *db-multi-sync-mutex*)
;; =not-used=  		 (if will-sync
;; =not-used=  		     (let (;; (max-sync-duration  (configf:lookup-number *configdat* "server" "max-sync-duration")) ;; KEEPING THIS AVAILABLE BUT SHOULD NOT USE, I'M PRETTY SURE IT DOES NOT WORK!
;; =not-used=  			   (sync-start         (current-milliseconds)))
;; =not-used=  		       (with-output-to-file start-file (lambda ()(print (current-process-id))))
;; =not-used=  		       
;; =not-used=  		       ;; put lock here
;; =not-used=  		       
;; =not-used=  		       ;; (if (or (not max-sync-duration)
;; =not-used=  		       ;;        (< sync-duration max-sync-duration)) ;; NOTE: db:sync-to-megatest.db keeps track of time of last sync and syncs incrementally
;; =not-used=  
;; =not-used=  		      ;;
;; =not-used=  		     
;; =not-used=  		       (for-each
;; =not-used=  			(lambda (subdb)
;; =not-used=  			  (let* (;;(dbstruct (db:setup))
;; =not-used=  				 (mtdb       (dbr:subdb-mtdbdat subdb))
;; =not-used=  				 (mtdb       (dbr:subdb-mtdbdat subdb))
;; =not-used=  				 (mtpath     (db:dbdat-get-path mtdb))
;; =not-used=  				 (tmp-area   (common:make-tmpdir-name *toppath* ""))
;; =not-used=  				 (res        (db:sync-to-megatest.db dbstruct no-sync-db: no-sync-db))) ;; did we sync any data? If so need to set the db touched flag to keep the server alive
;; =not-used=  			    (set! sync-duration (- (current-milliseconds) sync-start))
;; =not-used=  			    (if (> res 0) ;; some records were transferred, keep the db alive
;; =not-used=  				(begin
;; =not-used=  				  (mutex-lock! *heartbeat-mutex*)
;; =not-used=  				  (set! *db-last-access* (current-seconds))
;; =not-used=  				  (mutex-unlock! *heartbeat-mutex*)
;; =not-used=  				  (debug:print-info 0 *default-log-port* "sync called, " res " records transferred."))
;; =not-used=  				(debug:print-info 2 *default-log-port* "sync called but zero records transferred")))

;; =not-used=  			  )
;; =not-used=  			subdbs)))
;; =not-used=  		 
;; =not-used=  		 (if will-sync
;; =not-used=  		     (begin
;; =not-used=  		       (mutex-lock! *db-multi-sync-mutex*)
;; =not-used=  		       (set! *db-sync-in-progress* #f)
;; =not-used=  		       (set! *db-last-sync* start-time)
;; =not-used=  		       (with-output-to-file end-file (lambda ()(print (current-process-id))))
;; =not-used=  		       
;; =not-used=  		       ;; release lock here
;; =not-used=  		       
;; =not-used=  		       (mutex-unlock! *db-multi-sync-mutex*)))
;; =not-used=  		 (if (and debug-mode
;; =not-used=  			  (> (- start-time last-time) 60))
;; =not-used=  		     (begin
;; =not-used=  		       (set! last-time start-time)
;; =not-used=  		       (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*))))))
;; =not-used=  	       
;; =not-used= 	       ;; keep going unless time to exit
;; =not-used= 	       ;;
;; =not-used= 	       (if (not *time-to-exit*)
;; =not-used= 		   (let delay-loop ((count 0))
;; =not-used= 		     ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
;; =not-used= 		     
;; =not-used= 		     (if (and (not *time-to-exit*)
;; =not-used= 			      (< count 6)) ;; was 11, changing to 4. 
;; =not-used= 			 (begin
;; =not-used= 			   (thread-sleep! 1)
;; =not-used= 			   (delay-loop (+ count 1))))
;; =not-used= 		     (if (not *time-to-exit*) (loop))))
;; =not-used= 	       
;; =not-used= ;; 	       ;; time to exit, close the no-sync db here
;; =not-used= ;; 	       (db:no-sync-close-db no-sync-db stmt-cache)
;; =not-used= 	       (if (common:low-noise-print 30)
;; =not-used= 		   (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id) )))) 
;; =not-used= ))

(define (std-exit-procedure)
  ;;(common:telemetry-log-close)
  (on-exit (lambda () 0)) ;; why is this here?
  ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*)
  (let ((no-hurry  (if *time-to-exit* ;; hurry up
		       #f
5433
5434
5435
5436
5437
5438
5439

5440

5441
5442
5443
5444
5445
5446
5447
				       (sqlite3:database? *no-sync-db*))
				  (sqlite3:finalize! *no-sync-db* #t))
			      (if (and (not (args:get-arg "-server"))
				       *runremote*
				       (eq? (rmt:transport-mode) 'http))
				  (begin
				    (debug:print-info 0 *default-log-port* "Closing all client connections...")

				    (http-transport:close-connections *runremote*)

				    #;(http-client#close-all-connections!)))
                              ;; (if (and *runremote*
                              ;;          (remote-conndat *runremote*))
                              ;;     (begin
                              ;;       (http-client#close-all-connections!))) ;; for http-client
                              (if (not (eq? *default-log-port* (current-error-port)))
                                  (close-output-port *default-log-port*))







>
|
>







5223
5224
5225
5226
5227
5228
5229
5230
5231
5232
5233
5234
5235
5236
5237
5238
5239
				       (sqlite3:database? *no-sync-db*))
				  (sqlite3:finalize! *no-sync-db* #t))
			      (if (and (not (args:get-arg "-server"))
				       *runremote*
				       (eq? (rmt:transport-mode) 'http))
				  (begin
				    (debug:print-info 0 *default-log-port* "Closing all client connections...")
				    
				    ;; (http-transport:close-connections *runremote*) ;; <== no definition for this
				    
				    #;(http-client#close-all-connections!)))
                              ;; (if (and *runremote*
                              ;;          (remote-conndat *runremote*))
                              ;;     (begin
                              ;;       (http-client#close-all-connections!))) ;; for http-client
                              (if (not (eq? *default-log-port* (current-error-port)))
                                  (close-output-port *default-log-port*))
5460
5461
5462
5463
5464
5465
5466





























5467




















































      (thread-start! th2)
      (thread-join! th1)
      )
    )

  0)






























)



























































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
5252
5253
5254
5255
5256
5257
5258
5259
5260
5261
5262
5263
5264
5265
5266
5267
5268
5269
5270
5271
5272
5273
5274
5275
5276
5277
5278
5279
5280
5281
5282
5283
5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
5297
5298
5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
5311
5312
5313
5314
5315
5316
5317
5318
5319
5320
5321
5322
5323
5324
5325
5326
5327
5328
5329
5330
5331
5332
5333
5334
5335
5336
5337
5338
5339
5340
      (thread-start! th2)
      (thread-join! th1)
      )
    )

  0)

;; open an sql database inside a file lock
;; returns: db existed-prior-to-opening
;; RA => Returns a db handler; sets the lock if opened in writable mode
;;
;; (define *db-open-mutex* (make-mutex))
;;
(define (db:lock-create-open fname initproc)
  (let* ((parent-dir   (or (pathname-directory fname)(current-directory))) ;; no parent? go local
         (raw-fname    (pathname-file fname))
	 (dir-writable (file-write-access? parent-dir))
	 (file-exists  (common:file-exists? fname))
	 (file-write   (if file-exists
			   (file-write-access? fname)
			   dir-writable )))
    ;; (mutex-lock! *db-open-mutex*) ;; tried this mutex, not clear it helped.
    (if file-write ;; dir-writable
	(condition-case
         (let* ((lockfname   (conc fname ".lock"))
                (readyfname  (conc parent-dir "/.ready-" raw-fname))
                (readyexists (common:file-exists? readyfname)))
           (if (not readyexists)
               (common:simple-file-lock-and-wait lockfname))
           (let ((db      (sqlite3:open-database fname)))
             (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
             (sqlite3:execute db "PRAGMA synchronous = 0;")
             (if (and (configf:lookup *configdat* "setup" "tmp_mode") (string-match "^/tmp/.*" fname))
                 (begin
                   ;;(print "DEBUG: Setting tmp_mode for " fname) 
                   (sqlite3:execute db (configf:lookup *configdat* "setup" "tmp_mode"))
                   )
                 )  
             (if (and (configf:lookup *configdat* "setup" "nfs_mode") (not (string-match "^/tmp/.*" fname)))
                 (begin
                   ;;(print "DEBUG: Setting nfs_mode for " fname)
                   (sqlite3:execute db (configf:lookup *configdat* "setup" "nfs_mode"))
                   )
                 )  
             (if (and (not (or (configf:lookup *configdat* "setup" "tmp_mode") (configf:lookup *configdat* "setup" "nfs_mode")))  
                      (configf:lookup *configdat* "setup" "use-wal")
                      (string-match "^/tmp/.*" fname)) ;; this is a file in /tmp
                 (sqlite3:execute db "PRAGMA journal_mode=WAL;")
                 (debug:print 2 *default-log-port* "Creating " fname " in NON-WAL mode."))
             (if (not file-exists)
                 (initproc db))
             (if (not readyexists)
                 (begin
                   (common:simple-file-release-lock lockfname)
                   (with-output-to-file
                       readyfname
                     (lambda ()
                       (print "Ready at " 
                              (seconds->year-work-week/day-time 
                               (current-seconds)))))))
             db))
         (exn (io-error)  (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
         (exn (corrupt)   (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed."))
         (exn (busy)      (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back."))
         (exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem."))
         (exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn))))
        
	(condition-case
         (begin
           (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname)
           (let ((db (sqlite3:open-database fname)))
             (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
             (sqlite3:execute db "PRAGMA synchronous = 0;")
	     ;; (mutex-unlock! *db-open-mutex*)
             db))
         (exn (io-error)  (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
         (exn (corrupt)   (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed."))
         (exn (busy)      (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back."))
         (exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem."))
         (exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn))))
	)))


;; traps to catch usage of functions that need to be tracked down

(define (db:get-subdb . params)
  (assert #f "FATAL: Call to db:get-subdb - needs to be fixed."))

)