Megatest

Check-in [25d7080dba]
Login
Overview
Comment:corrected args on calls to db:setup, added transport mode files
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.80-revolution
Files: files | file ages | folders
SHA1: 25d7080dbadc2667b1e230840ae81c1fb08da2f1
User & Date: mmgraham on 2023-12-19 14:15:26
Other Links: branch diff | manifest | tags
Context
2023-12-20
12:46
changed rmt:get-count-tests-running to get-count-tests-running-for-run-id check-in: 6047a01091 user: mmgraham tags: v1.80-revolution
2023-12-19
14:15
corrected args on calls to db:setup, added transport mode files check-in: 25d7080dba user: mmgraham tags: v1.80-revolution
2023-12-15
19:59
changed the targets for transport-mode.scm and dashboard-transport-mode.scm to just copy instead of warning and not copying if the file exists already. check-in: d8e00d694e user: mmgraham tags: v1.80-revolution, v1.8024
Changes

Modified archive.scm from [e156e4a1c8] to [f055a5fe0c].

405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
   (let* ((bup-exe               (or (configf:lookup *configdat* "archive" "bup") "bup"))
         (archive-internal-path (conc (common:get-testsuite-name) "-megatest-db/" ts "/megatest.db" ))
         (bup-restore-params  (list "-d" archive-path "restore" "-C" *toppath* archive-internal-path)))
		 (debug:print-info 2 *default-log-port* "Restoring archived data to " *toppath* " from archive in " archive-path " ... " archive-internal-path)
		 (run-n-wait bup-exe params: bup-restore-params print-cmd: "Running:"))
      (sleep 2)
      (db:multi-db-sync 
       (db:setup #t) ;; (db:setup-db *dbstruct-dbs* *toppath* #f)
       'killservers
       ;'dejunk
       ;'adj-testids
       'old2new
       )
      (debug:print-info 1 *default-log-port* "dropping triggers to update linktree") 
      (rmt:drop-all-triggers)







|







405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
   (let* ((bup-exe               (or (configf:lookup *configdat* "archive" "bup") "bup"))
         (archive-internal-path (conc (common:get-testsuite-name) "-megatest-db/" ts "/megatest.db" ))
         (bup-restore-params  (list "-d" archive-path "restore" "-C" *toppath* archive-internal-path)))
		 (debug:print-info 2 *default-log-port* "Restoring archived data to " *toppath* " from archive in " archive-path " ... " archive-internal-path)
		 (run-n-wait bup-exe params: bup-restore-params print-cmd: "Running:"))
      (sleep 2)
      (db:multi-db-sync 
       (db:setup) ;; (db:setup-db *dbstruct-dbs* *toppath* #f)
       'killservers
       ;'dejunk
       ;'adj-testids
       'old2new
       )
      (debug:print-info 1 *default-log-port* "dropping triggers to update linktree") 
      (rmt:drop-all-triggers)

Modified common.scm from [0e724c12c1] to [8774919c9e].

611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
(define (common:exit-on-version-changed)
  (if (and *toppath*              ;; do nothing if *toppath* not yet provided
	   (common:on-homehost?))
      (if (common:api-changed?)
	  (let* ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config"))
                 (dbfile  (conc (get-environment-variable "MT_RUN_AREA_HOME") ".mtdb/main.db"))
                 (read-only (not (file-write-access? dbfile)))
                 (dbstruct (db:setup #t))) ;; (db:setup-db *dbstruct-dbs* *toppath* #f))) ;;  #t)))
	    (debug:print 0 *default-log-port*
			 "WARNING: Version mismatch!\n"
			 "   expected: " (common:version-signature) "\n"
			 "   got:      " (common:get-last-run-version))
            (cond
             ((get-environment-variable "MT_SKIP_DB_MIGRATE") #t)
             ((and (common:file-exists? mtconf) (common:file-exists? dbfile) (not read-only)







|







611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
(define (common:exit-on-version-changed)
  (if (and *toppath*              ;; do nothing if *toppath* not yet provided
	   (common:on-homehost?))
      (if (common:api-changed?)
	  (let* ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config"))
                 (dbfile  (conc (get-environment-variable "MT_RUN_AREA_HOME") ".mtdb/main.db"))
                 (read-only (not (file-write-access? dbfile)))
                 (dbstruct (db:setup))) ;; (db:setup-db *dbstruct-dbs* *toppath* #f))) ;;  #t)))
	    (debug:print 0 *default-log-port*
			 "WARNING: Version mismatch!\n"
			 "   expected: " (common:version-signature) "\n"
			 "   got:      " (common:get-last-run-version))
            (cond
             ((get-environment-variable "MT_SKIP_DB_MIGRATE") #t)
             ((and (common:file-exists? mtconf) (common:file-exists? dbfile) (not read-only)

Added dashboard-transport-mode.scm version [a7eb4115fd].













































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
;;======================================================================
;; set up transport, db cache and sync methods
;;
;; sync-method:        'original, 'attach or 'none
;; cache-method:       'tmp or 'none
;; rmt:transport-mode: 'http, 'tcp, 'nfs
;;
;; NOTE: NOT ALL COMBINATIONS WORK
;;
;;======================================================================

;; uncomment this block to test without tcp or cachedb
;; (dbfile:sync-method 'none)
;; (dbfile:cache-method 'none)
;; (rmt:transport-mode 'nfs)

;; uncomment this block to test with tcp and cachedb
(dbfile:sync-method 'none) ;; original was causing crash on start. 
(dbfile:cache-method 'none)
(rmt:transport-mode 'nfs)


Modified dashboard.scm from [09bc7d5e99] to [c1fb4f3795].

905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
		   (cont-run #f))
	  (let* ((run-id       (db:get-value-by-header run header "id"))
		 (recently-done  (< (- (current-seconds)
				       (hash-table-ref/default *dashboard-last-run-id-update* run-id 0)) 3))
		 (run-struct   (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f))
		 ;; (last-update  (if run-struct (dboard:rundat-last-update run-struct) 0))
		 (key-vals     (rmt:get-key-vals run-id))
		 (tests-ht     (let* ((tht (if recently-done
					       (let ((rht (dboard:rundat-tests run-struct))) ;; (dboard:tabdat-allruns-by-id tabdat)))
						 (or rht
						     (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)))
					       (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))))
				 (assert (hash-table? tht) "FATAL: But here tht should be a hash-table")
				 tht))
		 ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate
		 ;;  dboard:get-tests-for-run-duplicate - returns a hash table
		 ;;  (dboard:get-tests-dat tabdat run-id last-update))
		 (all-test-ids (hash-table-keys tests-ht))
		 (num-tests    (length all-test-ids))
		 ;; (print "run-struct: " run-struct)







|




|







905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
		   (cont-run #f))
	  (let* ((run-id       (db:get-value-by-header run header "id"))
		 (recently-done  (< (- (current-seconds)
				       (hash-table-ref/default *dashboard-last-run-id-update* run-id 0)) 3))
		 (run-struct   (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f))
		 ;; (last-update  (if run-struct (dboard:rundat-last-update run-struct) 0))
		 (key-vals     (rmt:get-key-vals run-id))
		 (tests-ht     (let* ((tht (if (and recently-done run-struct)
					       (let ((rht (dboard:rundat-tests run-struct))) ;; (dboard:tabdat-allruns-by-id tabdat)))
						 (or rht
						     (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)))
					       (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))))
                                (assert (hash-table? tht) "FATAL: But here tht should be a hash-table")
				 tht))
		 ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate
		 ;;  dboard:get-tests-for-run-duplicate - returns a hash table
		 ;;  (dboard:get-tests-dat tabdat run-id last-update))
		 (all-test-ids (hash-table-keys tests-ht))
		 (num-tests    (length all-test-ids))
		 ;; (print "run-struct: " run-struct)
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966

;; Sync to tmp only if in read-only mode.

(define (sync-db-to-tmp tabdat)
  (let* ((db-file "./.mtdb/main.db"))
    (if (and (not (file-write-access? db-file)) ( > (current-seconds) (+ last-copy-time 5)))
      (begin
        (db:multi-db-sync (db:setup #f) 'old2new)
        (set! last-copy-time (current-seconds))
      )
    )
  )
)

;; ########################### top level code ########################







|







3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966

;; Sync to tmp only if in read-only mode.

(define (sync-db-to-tmp tabdat)
  (let* ((db-file "./.mtdb/main.db"))
    (if (and (not (file-write-access? db-file)) ( > (current-seconds) (+ last-copy-time 5)))
      (begin
        (db:multi-db-sync (db:setup) 'old2new)
        (set! last-copy-time (current-seconds))
      )
    )
  )
)

;; ########################### top level code ########################

Modified db.scm from [e35040f27d] to [4c9582503f].

647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
			;;
			;; BUG: -mrw- I think this next line is wrong. run-id should be the path to .mtdb/<runid>.db
			;; 
			(tmpdb     (dbfile:open-db dbstruct run-id dbfile:db-init-proc)))
		   
                   (if dejunk
                     (begin
                       (debug:print 0 *default-log-port* "Cleaning nfs DB")
                       (db:clean-up run-id mtdb)
                       (debug:print 0 *default-log-port* "Cleaning tmp DB")
                       (db:clean-up run-id tmpdb)
                     )
                   )
		   (debug:print-info 2 *default-log-port* "delta syncing file: " srcfile ", time diff: " (- time1 time2) " seconds")
		   (if old2new
                       (begin
			 (db:sync-tables (db:sync-all-tables-list
					  (db:get-keys dbstruct))







|
|
|
|







647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
			;;
			;; BUG: -mrw- I think this next line is wrong. run-id should be the path to .mtdb/<runid>.db
			;; 
			(tmpdb     (dbfile:open-db dbstruct run-id dbfile:db-init-proc)))
		   
                   (if dejunk
                     (begin
                       (debug:print 0 *default-log-port* "Cleaning tmp DB")
                       (db:clean-up run-id tmpdb)
                       (debug:print 0 *default-log-port* "Cleaning nfs DB")
                       (db:clean-up run-id mtdb)
                     )
                   )
		   (debug:print-info 2 *default-log-port* "delta syncing file: " srcfile ", time diff: " (- time1 time2) " seconds")
		   (if old2new
                       (begin
			 (db:sync-tables (db:sync-all-tables-list
					  (db:get-keys dbstruct))

Modified megatest.scm from [c54fcd3e34] to [11c996f69d].

2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
    (begin
      (if (not (launch:setup))
	  (begin
	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 
	    (exit 1)))
      ;; keep this one local
      ;; (open-run-close patch-db #f)
      (let ((dbstructs (db:setup #f)))
        (common:cleanup-db dbstructs full: #t))
      (set! *didsomething* #t)))

(if (args:get-arg "-cleanup-db")
    (begin
      (if (not (launch:setup))
	  (begin







|







2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
    (begin
      (if (not (launch:setup))
	  (begin
	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 
	    (exit 1)))
      ;; keep this one local
      ;; (open-run-close patch-db #f)
      (let ((dbstructs (db:setup)))
        (common:cleanup-db dbstructs full: #t))
      (set! *didsomething* #t)))

(if (args:get-arg "-cleanup-db")
    (begin
      (if (not (launch:setup))
	  (begin
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
	(args:get-arg "-repl")
	(args:get-arg "-load"))
    (let* ((toppath (launch:setup))
	   (dbstructs (if (and toppath
			       ;; NOTE: server:choose-server is starting a server
			       ;;   either add equivalent for tcp mode or ????
                               #;(server:choose-server toppath 'home?))
                          (db:setup #t)
                          #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
      (if *toppath*
	  (cond
	   ((getenv "MT_RUNSCRIPT")
	    ;; How to run megatest scripts
	    ;;
	    ;; #!/bin/bash







|







2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
	(args:get-arg "-repl")
	(args:get-arg "-load"))
    (let* ((toppath (launch:setup))
	   (dbstructs (if (and toppath
			       ;; NOTE: server:choose-server is starting a server
			       ;;   either add equivalent for tcp mode or ????
                               #;(server:choose-server toppath 'home?))
                          (db:setup)
                          #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
      (if *toppath*
	  (cond
	   ((getenv "MT_RUNSCRIPT")
	    ;; How to run megatest scripts
	    ;;
	    ;; #!/bin/bash
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
;; ;; ;; redo me        (list "uname" "rundir" "final_logf" "comment"))
;; ;; ;; redo me       (set! *didsomething* #t)))

(if (args:get-arg "-import-megatest.db")
    (begin
      (launch:setup)
      (db:multi-db-sync 
       (db:setup #f)
       'killservers
       'dejunk
       'adj-testids
       'old2new
       )
      (set! *didsomething* #t)))

(if (args:get-arg "-import-sexpr")
    (begin
      (launch:setup)
      (rmt:import-sexpr (args:get-arg "-import-sexpr"))
      (set! *didsomething* #t)))

(if (args:get-arg "-sync-to-megatest.db")
    (let* ((duh      (launch:setup))
	   (dbstruct (db:setup #t))
	   (tmpdbpth (dbr:dbstruct-tmppath dbstruct))
	   (lockfile (conc tmpdbpth ".lock"))
	   (locked   (common:simple-file-lock lockfile)) 
	   (res      (if locked
			 (db:multi-db-sync 
			  dbstruct
			  'new2old)







|















|







2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
;; ;; ;; redo me        (list "uname" "rundir" "final_logf" "comment"))
;; ;; ;; redo me       (set! *didsomething* #t)))

(if (args:get-arg "-import-megatest.db")
    (begin
      (launch:setup)
      (db:multi-db-sync 
       (db:setup)
       'killservers
       'dejunk
       'adj-testids
       'old2new
       )
      (set! *didsomething* #t)))

(if (args:get-arg "-import-sexpr")
    (begin
      (launch:setup)
      (rmt:import-sexpr (args:get-arg "-import-sexpr"))
      (set! *didsomething* #t)))

(if (args:get-arg "-sync-to-megatest.db")
    (let* ((duh      (launch:setup))
	   (dbstruct (db:setup))
	   (tmpdbpth (dbr:dbstruct-tmppath dbstruct))
	   (lockfile (conc tmpdbpth ".lock"))
	   (locked   (common:simple-file-lock lockfile)) 
	   (res      (if locked
			 (db:multi-db-sync 
			  dbstruct
			  'new2old)

Modified rmt.scm from [c6584b1eb1] to [070a664ad0].

146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
			     (loop (car tal)(cdr tal) newmax-cmd currmax)))))))
    (mutex-unlock! *db-stats-mutex*)
    res))

(define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5))
  (let* ((qry-is-write    (not (member cmd api:read-only-queries)))
	 (db-file-path    (common:make-tmpdir-name *toppath* "")) ;;  0))
	 (dbstructs-local (db:setup #t))
	 (read-only       (not (file-write-access? db-file-path)))
	 (start           (current-milliseconds))
	 (resdat          (if (not (and read-only qry-is-write))
			      (let ((v (api:execute-requests dbstructs-local (vector (symbol->string cmd) params))))
			;;	(handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong..
			;;	 exn               ;;  This is an attempt to detect that situation and recover gracefully
			;;	 (begin







|







146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
			     (loop (car tal)(cdr tal) newmax-cmd currmax)))))))
    (mutex-unlock! *db-stats-mutex*)
    res))

(define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5))
  (let* ((qry-is-write    (not (member cmd api:read-only-queries)))
	 (db-file-path    (common:make-tmpdir-name *toppath* "")) ;;  0))
	 (dbstructs-local (db:setup))
	 (read-only       (not (file-write-access? db-file-path)))
	 (start           (current-milliseconds))
	 (resdat          (if (not (and read-only qry-is-write))
			      (let ((v (api:execute-requests dbstructs-local (vector (symbol->string cmd) params))))
			;;	(handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong..
			;;	 exn               ;;  This is an attempt to detect that situation and recover gracefully
			;;	 (begin

Added transport-mode.scm version [9dbf69644d].













































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
;;======================================================================
;; set up transport, db cache and sync methods
;;
;; sync-method:        'original, 'attach or 'none
;; cache-method:       'tmp 'none
;; rmt:transport-mode: 'http, 'tcp, 'nfs
;;
;; NOTE: NOT ALL COMBINATIONS WORK
;;
;;======================================================================

;; uncomment this block to test without tcp
;; (dbfile:sync-method 'none)
;; (dbfile:cache-method 'none)
;; (rmt:transport-mode 'nfs)

;; uncomment this block to test with tcp
(dbfile:sync-method 'attach) ;; attach) ;; original
(dbfile:cache-method 'tmp)
(rmt:transport-mode 'tcp)