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
				      (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*))


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







<
|
>
|
>
>







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

				   (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
	   (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
  ;; ping the server and ask it
  ;; if it ready
  (let* ((sdat (servdat-init #f host port #f)))
    (http-transport:send-receive sdat "abc" 'ping '())))










;; 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  '()))







|


|
|
>
>
>
>
>
>
>
>
>
|







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

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







|
|
|
>
|
|







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

	  (if srvready
	      (begin
		(hash-table-set! (rmt:remote-conns remote)
				 fullpath
				 (make-rmt:conn
				  apath:   apath
				  dbname:  dbname







<
|
>







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

	       (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

rel : 
	cd release;dashboard -rows 25 &

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

%.log : build unittests/%.scm $(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

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

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








|

>
|







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

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

(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"))







|







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
 )

(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"))