Megatest

Check-in [e2ce43a8fe]
Login
Overview
Comment:still trying
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.6569-multi-db-wip
Files: files | file ages | folders
SHA1: e2ce43a8fe6f277d260b84d66d574b3a4f91a5ce
User & Date: matt on 2021-02-13 23:02:24
Other Links: branch diff | manifest | tags
Context
2021-02-14
19:39
cleanup some duplicated functions check-in: a1bb05ec00 user: matt tags: v1.6569-multi-db-wip (unpublished)
2021-02-13
23:02
still trying check-in: e2ce43a8fe user: matt tags: v1.6569-multi-db-wip (unpublished)
21:42
code tidy check-in: 318542508d user: matt tags: v1.6569-multi-db-wip (unpublished)
Changes

Modified commonmod.scm from [efff2e3b21] to [872aa57f90].

836
837
838
839
840
841
842

843
844
845
846
847
848
849
(define *run-id*            #f)
(define *server-kind-run*   (make-hash-table))
(define *home-host*         #f)
;; (define *total-non-write-delay* 0)
(define *heartbeat-mutex*   (make-mutex))

(define *server-overloaded*  #f)


;; client
(define *rmt-mutex*         (make-mutex))     ;; remote access calls mutex 

;; RPC transport
(define *rpc:listener*      #f)








>







836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
(define *run-id*            #f)
(define *server-kind-run*   (make-hash-table))
(define *home-host*         #f)
;; (define *total-non-write-delay* 0)
(define *heartbeat-mutex*   (make-mutex))

(define *server-overloaded*  #f)
(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id

;; client
(define *rmt-mutex*         (make-mutex))     ;; remote access calls mutex 

;; RPC transport
(define *rpc:listener*      #f)

Modified dbmod.scm from [fea7eb8b6f] to [8c7923fe96].

2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
    thekey))

;; Get run-ids for runs with same target but different runnames and NOT run-id
;;
(define (db:get-prev-run-ids dbstruct run-id)
  (let* ((keyvals (db:get-key-val-pairs dbstruct run-id))
	 (kvalues (map cadr keyvals))
	 (keys    (db:get-keys))
	 (qrystr  (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")))
    (let ((prev-run-ids '()))
      (if (null? keyvals)
          '()
          (begin
            (db:with-db dbstruct #f #f ;; #f means work with the zeroth db - i.e. the runs db
                        (lambda (db)







|







2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
    thekey))

;; Get run-ids for runs with same target but different runnames and NOT run-id
;;
(define (db:get-prev-run-ids dbstruct run-id)
  (let* ((keyvals (db:get-key-val-pairs dbstruct run-id))
	 (kvalues (map cadr keyvals))
	 (keys    (db:get-keys dbstruct))
	 (qrystr  (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")))
    (let ((prev-run-ids '()))
      (if (null? keyvals)
          '()
          (begin
            (db:with-db dbstruct #f #f ;; #f means work with the zeroth db - i.e. the runs db
                        (lambda (db)

Modified megatest.scm from [ec5d5d8bf0] to [d545af0e1a].

61
62
63
64
65
66
67




68
69
70
71
72
73
74
(import servermod)
(declare (uses servermod.import))

(declare (uses apimod))
(import apimod)
(declare (uses apimod.import))





(define *db* #f) ;; this is only for the repl, do not use in general!!!!

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "megatest-fossil-hash.scm")







>
>
>
>







61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
(import servermod)
(declare (uses servermod.import))

(declare (uses apimod))
(import apimod)
(declare (uses apimod.import))

(declare (uses rmtmod))
(import rmtmod)
(declare (uses rmtmod.import))

(define *db* #f) ;; this is only for the repl, do not use in general!!!!

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "megatest-fossil-hash.scm")

Modified rmt.scm from [a3523dfa98] to [30f81906bb].

64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
			#f)))
	  (if cinfo
	      cinfo
	      (if (server:check-if-running areapath)
		  (client:setup areapath)
		  #f))))

(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id

(define (create-remote-record)
  (let ((rr (make-remote)))
    (remote-hh-dat-set!         rr (common:get-homehost)) ;
    (remote-server-info-set!    rr (if *toppath* (server:check-if-running *toppath*) #f))
    (remote-transport-set!      rr *transport-type*)
    (remote-server-timeout-set! rr (server:expiration-timeout))
    rr))







<
<







64
65
66
67
68
69
70


71
72
73
74
75
76
77
			#f)))
	  (if cinfo
	      cinfo
	      (if (server:check-if-running areapath)
		  (client:setup areapath)
		  #f))))



(define (create-remote-record)
  (let ((rr (make-remote)))
    (remote-hh-dat-set!         rr (common:get-homehost)) ;
    (remote-server-info-set!    rr (if *toppath* (server:check-if-running *toppath*) #f))
    (remote-transport-set!      rr *transport-type*)
    (remote-server-timeout-set! rr (server:expiration-timeout))
    rr))
461
462
463
464
465
466
467

468
469
470
471
472
473
474
  (rmt:send-receive 'start-server 0 (list run-id)))

;;======================================================================
;;  M I S C
;;======================================================================

(define (rmt:login run-id)

  (rmt:send-receive 'login run-id (list *toppath* megatest-version *my-client-signature*)))

;; This login does no retries under the hood - it acts a bit like a ping.
;; Deprecated for nmsg-transport.
;;
(define (rmt:login-no-auto-client-setup connection-info)
  (case *transport-type* ;; run-id of 0 is just a placeholder







>







459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
  (rmt:send-receive 'start-server 0 (list run-id)))

;;======================================================================
;;  M I S C
;;======================================================================

(define (rmt:login run-id)
  (assert *my-client-signature* "ERROR: login attempted without first calling (client:get-signature).")
  (rmt:send-receive 'login run-id (list *toppath* megatest-version *my-client-signature*)))

;; This login does no retries under the hood - it acts a bit like a ping.
;; Deprecated for nmsg-transport.
;;
(define (rmt:login-no-auto-client-setup connection-info)
  (case *transport-type* ;; run-id of 0 is just a placeholder

Modified tests/unittests/all-rmt.scm from [7374458dca] to [082436193f].

29
30
31
32
33
34
35

36
















37
38
39
40
41
42
43
;;   NTN - no test needed
;;   DEP - function is deprecated, no point in testing
;;   NED - function nested under others, no test needed.
;;   DEF - deferred

(import commonmod)
(import dbmod)

(use matchable)

















(print "start dir: " (current-directory))
       
(define toppath (current-directory))

(test #f #f (server:check-if-running toppath))           ;; these are used by server:start-and-wait
(test #f #t (list? (server:get-list toppath)))







>

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
;;   NTN - no test needed
;;   DEP - function is deprecated, no point in testing
;;   NED - function nested under others, no test needed.
;;   DEF - deferred

(import commonmod)
(import dbmod)
(import rmtmod)
(use matchable)

(use trace)
(trace
 rmt:login
 db:login
 rmt:send-receive
 rmtmod:calc-ro-mode
 create-remote-record
 rmt:open-qry-close-locally
 common:force-server?
 server:check-if-running
 server:record->id
 extras-case-11
 extras-transport-failed
 extras-transport-succeded
 )

(print "start dir: " (current-directory))
       
(define toppath (current-directory))

(test #f #f (server:check-if-running toppath))           ;; these are used by server:start-and-wait
(test #f #t (list? (server:get-list toppath)))
77
78
79
80
81
82
83
84
85
86
87

88
89
90
91
92
93
94

(test "setup for run" #t (begin (launch:setup)
 				(string? (getenv "MT_RUN_AREA_HOME"))))
(test #f #t (string? (vector-ref (client:setup-http toppath) 0)))
(test #f #t (vector? (client:setup toppath)))

(test #f #t (vector? (rmt:get-connection-info toppath))) ;; TODO: push areapath down.
(test #f #t (string? (server:check-if-running toppath)))
;; DEF (test #f #f (rmt:send-receive-no-auto-client-setup *runremote* 'get-keys #f '()))
;; DEF (rmt:kill-server run-id)
;; DEF (rmt:start-server run-id)

(test #f '(#t "successful login")(rmt:login #f))
;; DEF (rmt:login-no-auto-client-setup connection-info)
(test #f #t (pair? (rmt:get-latest-host-load (get-host-name))))

;; get-latest-host-load does a lookup in the db, it won't return a useful value unless
;; a test ran recently on host
(test-batch rmt:get-latest-host-load







|



>







94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112

(test "setup for run" #t (begin (launch:setup)
 				(string? (getenv "MT_RUN_AREA_HOME"))))
(test #f #t (string? (vector-ref (client:setup-http toppath) 0)))
(test #f #t (vector? (client:setup toppath)))

(test #f #t (vector? (rmt:get-connection-info toppath))) ;; TODO: push areapath down.
(test #f #t (list? (server:check-if-running toppath)))
;; DEF (test #f #f (rmt:send-receive-no-auto-client-setup *runremote* 'get-keys #f '()))
;; DEF (rmt:kill-server run-id)
;; DEF (rmt:start-server run-id)
(test #f #t (string? (client:get-signature)))
(test #f '(#t "successful login")(rmt:login #f))
;; DEF (rmt:login-no-auto-client-setup connection-info)
(test #f #t (pair? (rmt:get-latest-host-load (get-host-name))))

;; get-latest-host-load does a lookup in the db, it won't return a useful value unless
;; a test ran recently on host
(test-batch rmt:get-latest-host-load