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
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
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))
	 (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
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
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 *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))
461
462
463
464
465
466
467

468
469
470
471
472
473
474
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
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
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 (string? (server:check-if-running toppath)))
(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