Megatest

Check-in [0453b5d22b]
Login
Overview
Comment:Simplify running of unit tests, simplified ping
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.6584-ck5
Files: files | file ages | folders
SHA1: 0453b5d22b0b48130ea3498fb96e73f3c1ada8e4
User & Date: matt on 2021-05-09 23:42:01
Other Links: branch diff | manifest | tags
Context
2021-05-10
22:53
Got loop-test working check-in: ba4f089eda user: matt tags: v1.6584-ck5
2021-05-09
23:42
Simplify running of unit tests, simplified ping check-in: 0453b5d22b user: matt tags: v1.6584-ck5
2021-05-08
22:47
Unit test coming along. check-in: 51225a42e5 user: matt tags: v1.6584-ck5
Changes

Modified http-transportmod.scm from [7d98658692] to [853954beaf].

167
168
169
170
171
172
173
174
175
176





177
178
179
180
181
182
183
167
168
169
170
171
172
173



174
175
176
177
178
179
180
181
182
183
184
185







-
-
-
+
+
+
+
+







				      (res #f))
				 (cond
				  ((equal? (uri-path (request-uri (current-request)))
					   '(/ "api"))
				   (send-response ;; the $ is the request vars proc
				    body: ((api-proc) *dbstruct-db* $)
				    headers: '((content-type text/plain)))
				   (mutex-lock! *heartbeat-mutex*)
				   (set! *db-last-access* (current-seconds))
				   (mutex-unlock! *heartbeat-mutex*))
				   (set! *db-last-access* (current-seconds)))
				  ((equal? (uri-path (request-uri (current-request))) 
					   '(/ "ping"))
				   (send-response body: (conc *toppath*"/"(args:get-arg "-db"))
						  headers: '((content-type text/plain))))
				  ((equal? (uri-path (request-uri (current-request))) 
					   '(/ ""))
				   (send-response body: ((http-get-function 'http-transport:main-page))))
				  ((equal? (uri-path (request-uri (current-request))) 
					   '(/ "json_api"))
				   (send-response body: ((http-get-function 'http-transport:main-page))))
				  ((equal? (uri-path (request-uri (current-request))) 
464
465
466
467
468
469
470
471

472
473
474
475
476












477
478
479
480
481
482
483
466
467
468
469
470
471
472

473
474
475



476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494







-
+


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







	   (read-pkt->alist pkt-file pktspec: pktspec))
	 all-pkt-files)))

(define (server-address srv-pkt)
  (conc (alist-ref 'host srv-pkt) ":"
	(alist-ref 'port srv-pkt)))
	
(define (server-ready? host port) ;; server-address is host:port
(define (server-ready? host port key) ;; server-address is host:port
  ;; ping the server and ask it
  ;; if it ready
  (let* ((sdat (servdat-init #f host port #f)))
    (http-transport:send-receive sdat "abc" 'ping '())))

  ;; (let* ((sdat (servdat-init #f host port #f)))
  ;;   (http-transport:send-receive sdat "abc" 'ping '())))
  (let* ((res (with-input-from-request
	       (conc "http://"host":"port"/ping") ;; returns *toppath*/dbname
	       #f
	       read-string)))
    (if (equal? res key)
	#t
	(begin
	  (debug:print-info 0 *default-log-port* "server-ready? key="key", received="res)
	  #f))))
	      
;; from the pkts return servers associated with dbpath
;; NOTE: Only one can be alive - have to check on each
;;       in the list of pkts returned
;;
(define (get-viable-servers serv-pkts dbpath)
  (let loop ((tail serv-pkts)
	     (res  '()))
491
492
493
494
495
496
497
498
499
500
501
502






503
504
505
506
507
508
509
502
503
504
505
506
507
508





509
510
511
512
513
514
515
516
517
518
519
520
521







-
-
-
-
-
+
+
+
+
+
+








;; from viable servers get one that is alive and ready
;;
(define (get-the-server serv-pkts)
  (let loop ((tail serv-pkts))
    (if (null? tail)
	#f
	(let* ((spkt (car tail))
	       (host (alist-ref 'ipaddr spkt))
	       (port (alist-ref 'port spkt))
	       (addr (server-address spkt)))
	  (if (server-ready? host port)
	(let* ((spkt  (car tail))
	       (host  (alist-ref 'ipaddr spkt))
	       (port  (alist-ref 'port spkt))
	       (dbpth (alist-ref 'dbpath spkt))
	       (addr  (server-address spkt)))
	  (if (server-ready? host port dbpth)
	      spkt
	      (loop (cdr tail)))))))

;; am I the "first" in line server? I.e. my D card is smallest
;; use Z card as tie breaker
;;
(define (get-best-candidate serv-pkts dbpath)

Modified rmtmod.scm from [68e1f7f6c8] to [e114506d72].

203
204
205
206
207
208
209
210
211


212
213
214
215
216
217
218
203
204
205
206
207
208
209


210
211
212
213
214
215
216
217
218







-
-
+
+







			   (thread-sleep! 1.5)
			   (rmt:open-main-connection remote apath) ;; TODO: Add limit to number of tries
			   )))
    (if the-srv ;; yes, we have a server, now try connecting to it
	(let* ((srv-addr (server-address the-srv))
	       (ipaddr   (alist-ref 'ipaddr the-srv))
	       (port     (alist-ref 'port   the-srv))
	       (srvready (server-ready? ipaddr port))
	       (fullpath (db:dbname->path apath dbname)))
	       (fullpath (db:dbname->path apath dbname))
	       (srvready (server-ready? ipaddr port fullpath)))
	  (if srvready
	      (begin
		(hash-table-set! (rmt:remote-conns remote)
				 fullpath
				 (make-rmt:conn
				  apath:   apath
				  dbname:  dbname

Modified tests/Makefile from [b8d7fd37e9] to [f693c2a7e2].

51
52
53
54
55
56
57
58

59

60

61
62
63
64
65
66
67
51
52
53
54
55
56
57

58
59
60

61
62
63
64
65
66
67
68







-
+

+
-
+








rel : 
	cd release;dashboard -rows 25 &

## basicserver.log : unittests/basicserver.scm
## 	script -c "./rununittest.sh basicserver $(DEBUG)" basicserver.log

%.log : build unittests/%.scm $(MTEST)
%.log : unittests/%.scm ../bin/.*/mtest
	script -c "./rununittest.sh $* $(DEBUG)" $*.log

	if logpro unit.logpro $*.html < $*.log > /dev/null;then echo ALLPASS;else echo ALLFAIL;mv $*.log $*.log.FAIL;fi
# if logpro unit.logpro $*.html < $*.log > /dev/null;then echo ALLPASS;else echo ALLFAIL;mv $*.log $*.log.FAIL;fi

server :
	cd fullrun;$(MEGATEST) -server - -debug $(DEBUG) -run-id $(RUNID)

stopserver :
	cd fullrun;$(MEGATEST) -stop-server 0

Modified tests/unittests/basicserver.scm from [0c881772ab] to [e95e668f31].

21
22
23
24
25
26
27
28

29
30
31
32
33
34
35
21
22
23
24
25
26
27

28
29
30
31
32
33
34
35







-
+







;; Run like this:
;;
;;  ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0)

(import rmtmod trace)
(trace-call-sites #t)
(trace
 rmt:find-main-server
 ;; rmt:find-main-server
 )

(test #f #t (rmt:remote? (let ((r (make-rmt:remote)))
			   (set! *rmt:remote* r)
			   r)))
(test #f #f (rmt:get-connection *rmt:remote* *toppath* ".db/main.db"))
(test #f #f (rmt:find-main-server *toppath* ".db/main.db"))