Megatest

Check-in [58cfc286d8]
Login
Overview
Comment:wip
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v2.001
Files: files | file ages | folders
SHA1: 58cfc286d81fa5c26a05397b1f9113a02f437f6a
User & Date: matt on 2021-12-21 12:46:16
Other Links: branch diff | manifest | tags
Context
2021-12-21
17:47
all-rmt unit tests pass check-in: 9f85a4b1dd user: matt tags: v2.001
12:46
wip check-in: 58cfc286d8 user: matt tags: v2.001
2021-12-20
18:48
wip check-in: a9fa8512c8 user: matt tags: v2.001
Changes

Modified apimod.scm from [f6411932bc] to [f47a08f057].

37
38
39
40
41
42
43

44
45
46
47
48
49
50
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51







+







(import scheme
	chicken.base
	chicken.process-context.posix
	chicken.string
	chicken.time
	chicken.condition
	chicken.process
	chicken.pathname
	chicken.random
	chicken.file
	
	;; (prefix sqlite3 sqlite3:)
	typed-records
	srfi-18
	srfi-69
164
165
166
167
168
169
170








171
172


173
174
175
176
177
178
179
180
181
182
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179


180
181



182
183
184
185
186
187
188







+
+
+
+
+
+
+
+
-
-
+
+
-
-
-








    ;; TASKS
    tasks-add
    tasks-set-state-given-param-key
    ))

(define (api:run-server-process apath dbname)
  (let* ((cleandbname (pathname-strip-directory dbname)) ;; (string-translate dbname "./" "--"))
	 (logd        (conc apath "/logs")) 
	 (logf        (conc logd "/server-launch-";;(current-process-id)
			    (seconds->year-work-week/day-time-fname (current-seconds))
			    "-"cleandbname".log"))
	 (logf2       (conc logd "/server-"
			    (seconds->year-work-week/day-time-fname (current-seconds))
			    "-"cleandbname"-"))
  (let* ((cmd  (conc "nbfake megatest -server - -area "apath
		     " -db "dbname))
	 (cmd  (conc "nbfake megatest -server - -area "apath
		     " -db "dbname" -autolog "logf2)))
	 (cleandbname (string-translate dbname "./" "_-"))
	 (logd (conc apath "/logs")) 
	 (logf (conc logd "/server-"(current-seconds)cleandbname".log")))
    (if (not (directory-exists? logd))
	(create-directory logd #t))
    (system (conc "NBFAKE_LOG="logf" "cmd))))

;; special function to get server
;; look up in db
;; if found -> return it
342
343
344
345
346
347
348
349

350
351
352
353
354
355
356
348
349
350
351
352
353
354

355
356
357
358
359
360
361
362







-
+







    ((get-runs-cnt-by-patt)         (apply db:get-runs-cnt-by-patt dbstruct params))
    ((get-all-run-ids)              (db:get-all-run-ids dbstruct))
    ((get-prev-run-ids)             (apply db:get-prev-run-ids dbstruct params))
    ((get-run-ids-matching-target)  (apply db:get-run-ids-matching-target dbstruct params))
    ((get-runs-by-patt)             (apply db:get-runs-by-patt dbstruct params))
    ((get-run-name-from-id)         (apply db:get-run-name-from-id dbstruct params))
    ((get-main-run-stats)           (apply db:get-main-run-stats dbstruct params))
    ((log-to-main)                  (apply debug:print params))
    ((log-to-main)                  (apply debug:print 0 *default-log-port* params))
    ((get-var)                      (apply db:get-var dbstruct params))
    ((get-run-stats)                (apply db:get-run-stats dbstruct params))
    ((get-run-times)                (apply db:get-run-times dbstruct params)) 

    ;; STEPS
    ((get-steps-data)               (apply db:get-steps-data dbstruct params))
    ((get-steps-for-test)           (apply db:get-steps-for-test dbstruct params))

Modified build-assist/ck5-eggs.list from [50ec309d57] to [6d7e206485].

1
2
3
4
5
6
7
8

9
10
11
12
13
14
15
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16








+







csm
address-info
ansi-escape-sequences
apropos
base64
crypt
csv-abnf
directory-utils
dot-locking
filepath
fmt
format
http-client
itemsmod
json
linenoise

Modified commonmod.scm from [66ca132e41] to [787a13f0a3].

312
313
314
315
316
317
318

319
320
321
322
323
324
325
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326







+







common:hms-string->seconds
seconds->hr-min-sec
seconds->time-string
seconds->work-week/day-time
seconds->work-week/day
seconds->year-work-week/day
seconds->year-work-week/day-time
seconds->year-work-week/day-time-fname
seconds->year-week/day-time
seconds->quarter
common:date-time->seconds
common:find-start-mark-and-mark-delta
common:expand-cron-slash
common:cron-expand
common:cron-event
3577
3578
3579
3580
3581
3582
3583




3584
3585
3586
3587
3588
3589
3590
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595







+
+
+
+







(define (seconds->work-week/day sec)
  (time->string
   (seconds->local-time sec) "ww%V.%u"))

(define (seconds->year-work-week/day sec)
  (time->string
   (seconds->local-time sec) "%yww%V.%w"))

(define (seconds->year-work-week/day-time-fname sec)
  (time->string
   (seconds->local-time sec) "%yww%V.%w.%H%M%S"))

(define (seconds->year-work-week/day-time sec)
  (time->string
   (seconds->local-time sec) "%Yww%V.%w %H:%M"))

(define (seconds->year-week/day-time sec)
  (time->string

Modified configfmod.scm from [0f89b247bb] to [b4853bf0ef].

84
85
86
87
88
89
90

91
92
93
94
95
96
97
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98







+







	keysmod

	(prefix base64 base64:)
	(prefix dbi dbi:)
	(prefix sqlite3 sqlite3:)
	(srfi 18)
	directory-utils
	dot-locking
	format
	matchable
	md5
	message-digest
	regex
	regex-case
	sparse-vectors
110
111
112
113
114
115
116





117
118
119
120
121
122
123
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129







+
+
+
+
+








;;======================================================================
;; parameters
;;======================================================================

;; while targets are Megatest specific they are a useful concept
(define mytarget (make-parameter #f))

;; locking is optional, many environments don't care (e.g. running on one machine)
;; NOTE: the locker must follow the same syntax as with-dot-lock*
;;
(define my-with-lock (make-parameter with-dot-lock*))

;;======================================================================
;; move debug stuff to separate module then put these back where they belong
;;======================================================================
;;======================================================================
;; lookup routines - replicated from configf
;;======================================================================
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
















1204
1205
1206
1207
1208
1209
1210
1211







1212
1213

1214
1215
1216
1217
1218
1219
1190
1191
1192
1193
1194
1195
1196













1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213







1214
1215
1216
1217
1218
1219
1220


1221
1222
1223
1224
1225
1226
1227







-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

-
-
-
-
-
-
-
+
+
+
+
+
+
+
-
-
+







;;======================================================================
;; DO THE LOCKING AROUND THE CALL
;;======================================================================
;;
(define (configf:write-alist cdat fname)
  ;; (if (not (common:faux-lock fname))
  (debug:print 0 *default-log-port* "INFO: NEED LOCKING ADDED HERE " fname)
  (let* ((dat  (configf:config->alist cdat))
         (res
          (begin
            (with-output-to-file fname ;; first write out the file
              (lambda ()
                (pp dat)))
            ;; I don't like this. It makes write-alist opaque and complicated. -mrw-
            (if (file-exists? fname)   ;; now verify it is readable
                (if (configf:read-alist fname)
                    #t ;; data is good.
                    (begin
                      (handle-exceptions
  ;; (debug:print 0 *default-log-port* "INFO: NEED LOCKING ADDED HERE " fname)
  ((my-with-lock)
   fname
   (lambda ()
     (let* ((dat  (configf:config->alist cdat))
            (res
             (begin
               (with-output-to-file fname ;; first write out the file
		 (lambda ()
                   (pp dat)))
               ;; I don't like this. It makes write-alist opaque and complicated. -mrw-
               (if (file-exists? fname)   ;; now verify it is readable
                   (if (configf:read-alist fname)
                       #t ;; data is good.
                       (begin
			 (handle-exceptions
			  exn
			(begin
			  (debug:print 0 *default-log-port* "deleting " fname " failed, exn=" exn)
			  #f)
			(debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.")
			(delete-file fname))
                      #f))
                #f))))
			  (begin
			    (debug:print 0 *default-log-port* "deleting " fname " failed, exn=" exn)
			    #f)
			  (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.")
			  (delete-file fname))
			 #f))
                   #f))))
    ;; (common:faux-unlock fname)
    res))
       res))))
  
(define (common:get-fields cfgdat)
  (let ((fields (hash-table-ref/default cfgdat "fields" '())))
    (map car fields)))

)

Modified debugprint.scm from [9a1ffc1e9a] to [2f3aa7f0ad].

102
103
104
105
106
107
108
109
110




111
112
113
114
115
116
117
102
103
104
105
106
107
108


109
110
111
112
113
114
115
116
117
118
119







-
-
+
+
+
+







      (not (null? (lset-intersection! eq? vb n))))
     ((and (number? vb)
	   (list? n))
      (member vb n))
     (else #f))))

(define (debug:handle-remote-logging params)
  (if (debug:print-logger)
      (apply (debug:print-logger) "REMOTE ("(get-host-name)", pid="(current-process-id)") " params)))
  (if (debug:print-logger) ;; NOTE: turn params into string to keep things simple for now
      ((debug:print-logger)(conc "REMOTE ("(get-host-name)", pid="(current-process-id)") "
				 (string-intersperse (map conc params) " ") "; "
				 (string-intersperse (command-line-arguments) " ")))))

(define (debug:print n e . params)
  (if (debug:debug-mode n)
      (with-output-to-port (or e (current-error-port))
	(lambda ()
	  ;; (if *logging*
	      ;; (db:log-event (apply conc params))

Modified megatest.scm from [89bdcd6c8f] to [c1c08ee586].

435
436
437
438
439
440
441

442
443
444
445
446
447
448
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449







+







                                 overwritten by values set in config files.
  -server -|hostname      : start the server (reduces contention on megatest.db), use
                            - to automatically figure out hostname
  -adjutant C,M           : start the server/adjutant with allocated cores C and Mem M (Gig), 
                            use 0,0 to auto use full machine
  -transport http|rpc     : use http or rpc for transport (default is http) 
  -log logfile            : send stdout and stderr to logfile
  -autolog logfilebase    : appends pid and host to logfilebase for logfile
  -list-servers           : list the servers 
  -kill-servers           : kill all servers
  -repl                   : start a repl (useful for extending megatest)
  -load file.scm          : load and run file.scm
  -mark-incompletes       : find and mark incomplete tests
  -ping run-id|host:port  : ping server, exit with 0 if found
  -debug N|N,M,O...       : enable debug 0-N or N and M and O ...
628
629
630
631
632
633
634

635
636
637
638
639
640
641
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643







+







     			"-var"
     			"-dumpmode"
     			"-run-id"
     			"-ping"
     			"-refdb2dat"
     			"-o"
     			"-log"
			"-autolog"
			"-sync-log"
     			"-since"
     			"-fields"
     			"-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state
     			"-sort"
     			"-target-db"
     			"-source-db"
782
783
784
785
786
787
788
789


790
791
792
793
794


795
796
797
798





799
800
801
802
803
804
805
784
785
786
787
788
789
790

791
792
793
794
795
796
797
798
799




800
801
802
803
804
805
806
807
808
809
810
811







-
+
+





+
+
-
-
-
-
+
+
+
+
+







;;      	 (list? n))
;;          (member *verbosity* n))))

     ;; this segment will run launch:setup only if -log is not set. This is fairly safe as servers are not
     ;; manually started and thus should never be started in a non-megatest area. Thus no need to handle situation
     ;; where (launch:setup) returns #f?
     ;;
     (if (or (args:get-arg "-log")#;(args:get-arg "-server")) ;; redirect the log always when a server
     (if (or (args:get-arg "-log") ;;(args:get-arg "-server") ;; redirect the log always when a server
	     (args:get-arg "-autolog"))
         (handle-exceptions
     	exn
     	(begin
     	  (print "ERROR: Failed to switch to log output. " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
     	  )
        (let* ((tl   (or (args:get-arg "-log")
			 (args:get-arg "-autolog") ;; autolog provides the basename .../logs/something- for the logfile
           (let* ((tl   (or (args:get-arg "-log")(launch:setup)))   ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified
     	     (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name
     		       (conc tl "/logs/server-" (current-process-id) "-" (get-host-name) ".log")))
     	     (oup  (open-logfile logf)))
			 (launch:setup)))   ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified
     	       (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name
			 (conc tl (current-process-id)"-"(get-host-name)".log")
     			 (conc tl "/logs/server-" (current-process-id) "-" (get-host-name) ".log")))
     	       (oup  (open-logfile logf)))
     	(if (not (args:get-arg "-log"))
     	    (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log
     	(debug:print-info 0 *default-log-port* "Sending log output to " logf)
     	(set! *default-log-port* oup))))
     
     (if (or (args:get-arg "-h")
     	(args:get-arg "-help")

Modified rmtmod.scm from [53bb074bb9] to [4d23f52ced].

263
264
265
266
267
268
269





270
271
272
273
274
275
276
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281







+
+
+
+
+







;;
(define (rmt:general-open-connection remdat apath dbname #!key (num-tries 5))
  (assert (not (equal? dbname ".db/main.db")) "ERROR: general-open-connection should never be called with main as the db")
  (let* ((mdbname  (db:run-id->dbname #f))
	 (fullname (db:dbname->path apath dbname))
	 (conns    (remotedat-conns remdat))
	 (mconn    (rmt:get-conn remdat apath mdbname)))
    (if (and mconn
	     (not (debug:print-logger)))
	(begin
	  (debug:print-info 0 *default-log-port* "Turning on logging to main, look in logs dir for main log.")
	  (debug:print-logger rmt:log-to-main)))
    (cond
     ((or (not mconn) ;; no channel open to main?
	  (< (conndat-expires mconn)(+ (current-seconds) 2))) ;; restablish connection if less than 2 seconds on the lease
      (rmt:open-main-connection remdat apath)
      (rmt:general-open-connection remdat apath mdbname))
     ((not (rmt:get-conn remdat apath dbname))                 ;; no channel open to dbname?     
      (let* ((res (rmt:send-receive-real remdat apath mdbname 'get-server `(,apath ,dbname))))
308
309
310
311
312
313
314
315

316
317
318
319
320
321
322
323
324
325
326
313
314
315
316
317
318
319

320




321
322
323
324
325
326
327







-
+
-
-
-
-







				     expires: (+ (current-seconds) 60))))
		  (else
		   (debug:print-info 0 *default-log-port* "return data from starting server did not match host port servkey pid ipaddr apath dbname " res)))
		 res)
	       (begin
		 (debug:print-info 0 *default-log-port* "Unexpected result: " res)
		 res)))))))
    (if (and mconn
    
	     (not (debug:print-logger)))
	(begin
	  (debug:print-info 0 *default-log-port* "Turning on logging to main, look in logs dir for main log.")
	  (debug:print-logger rmt:log-to-main)))
    #t))

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

;; FOR DEBUGGING SET TO #t
;; (define *localmode* #t)
(define *localmode* #f)
363
364
365
366
367
368
369
370
371




372
373
374
375
376
377
378
364
365
366
367
368
369
370


371
372
373
374
375
376
377
378
379
380
381







-
-
+
+
+
+







	   (key     #f)
	   (host    (conndat-ipaddr conn))
	   (port    (conndat-port   conn))
	   (payload `((cmd    . ,cmd)
		      (key    . ,(conndat-srvkey conn))
		      (params . ,params)))
	   (res      (send-receive-nn soc ;; (open-send-receive-nn (conc host":"port)
					   (sexpr->string payload))))
      (string->sexpr res))))
				      (sexpr->string payload))))
      (if (member res '("#<unspecified>")) ;; TODO - fix this in string->sexpr
	  #f
	  (string->sexpr res)))))

;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed
;; sometime in the future.
;;
;; Purpose - call the main.db server and request a server be started
;; for the given area path and dbname
;;
792
793
794
795
796
797
798
799

800
801
802
803
804
805
806
795
796
797
798
799
800
801

802
803
804
805
806
807
808
809







-
+







  (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime))
  ) ;; )

(define (rmt:get-main-run-stats run-id)
  (rmt:send-receive 'get-main-run-stats #f (list run-id)))

(define (rmt:log-to-main . params)
  (rmt:send-receive 'log-to-main #f (cons #f params)))
  (rmt:send-receive 'log-to-main #f params))

(define (rmt:get-var run-id varname)
  (rmt:send-receive 'get-var run-id (list run-id varname)))

(define (rmt:del-var run-id varname)
  (rmt:send-receive 'del-var run-id (list run-id varname)))

1635
1636
1637
1638
1639
1640
1641

1642
1643
1644
1645
1646

1647
1648
1649
1650
1651
1652
1653
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649

1650
1651
1652
1653
1654
1655
1656
1657







+




-
+







;;======================================================================
;; S E R V E R
;; ======================================================================

(define (http-get-function fnkey)
  (hash-table-ref/default *http-functions* fnkey (lambda () "nothing here yet")))

;; Main entry point to start a server. was start-server
(define (rmt:run hostn)
  ;;  ;; Configurations for server
  ;;  (tcp-buffer-size 2048)
  ;;  (max-connections 2048) 
  (debug:print 2 *default-log-port* "Attempting to start the server ...")
  (debug:print 2 *default-log-port* "PID: "(current-process-id)". Attempting to start the server ...")
  (let* ((db              #f) ;;        (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily
	 (hostname        (get-host-name))
	 (ipaddrstr       (let ((ipstr (if (string=? "-" hostn)
					   ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
					   (server:get-best-guess-address hostname)
					   #f)))
			    (if ipstr ipstr hostn))) ;; hostname))) 

Added tests/simplerun/Makefile version [38acf6b450].




1
2
3
+
+
+

cleanup :
	killall mtest -v -9;rm -rf .meta .db

Modified tests/simplerun/megatest.config from [373cc8c0cf] to [3e9fa2e5ac].

34
35
36
37
38
39
40
41

42
43
44
45
46
47
48
34
35
36
37
38
39
40

41
42
43
44
45
46
47
48







-
+







# Valid values for state and status for steps, NB// It is not recommended you use this
[validvalues]
state start end completed

# Job tools are more advanced ways to control how your jobs are launched
[jobtools]
useshell yes
launcher nbfind
launcher nbfake

# You can override environment variables for all your tests here
[env-override]
EXAMPLE_VAR example value

# As you run more tests you may need to add additional disks, the names are arbitrary but must be unique
[disks]

Modified tests/unittests/server.scm from [68d25c84e5] to [7bdfa0e7f2].

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








-
+













+
-
-
+
+


-
(test #f #t (conndat? (rmt:get-conn *remotedat* *toppath* ".db/main.db")))
(test #f #t (conndat? (rmt:get-conn *remotedat* *toppath* ".db/main.db")))
(test #f ".db/2.db" (list-ref (rmt:send-receive-real *remotedat* *toppath* ".db/main.db" 'get-server `(,apath ,dbname))
			      6))

(thread-sleep! 2)
(test #f #t (rmt:general-open-connection *remotedat* *toppath* ".db/2.db"))

(test #f #t (list? (rmt:get-servers-info *toppath*)))

(test #f '("SYSTEM" "RELEASE") (rmt:get-keys))
(test #f 1 (rmt:send-receive 'register-run #f (list keyvals "run1" "new" "n/a" "justme" #f)))
;; (print "Got here.")

(test #f 1 (rmt:send-receive 'register-run 1 (list keyvals "run1" "new" "n/a" "justme" #f)))

(test #f 2 (rmt:register-run keyvals "run2" "new" "n/a" "justme" #f))
;; (test #f 2 (rmt:deregister-server *remotedat* *toppath* iface port server-key dbname

(test #f 2 (rmt:get-count-servers *remotedat* *toppath*))

(test #f "run2" (rmt:get-run-name-from-id 2))
(test #f #f     (rmt:send-receive 'get-test-info-by-id 2 '(2 1)))

(test #f #t (list? (rmt:get-servers-info *toppath*)))
      
(test #f #t     (rmt:general-call 'update-cpuload-diskfree 2 1.5 1e6 1))

(exit)