Megatest

Check-in [a486adf12f]
Login
Overview
Comment:fixed get-servers-info
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v2.001
Files: files | file ages | folders
SHA1: a486adf12f40626c7ee0ba093dfd26bc10df9c5e
User & Date: matt on 2021-12-20 15:57:17
Other Links: branch diff | manifest | tags
Context
2021-12-20
16:26
Basic listing of servers working check-in: 4e80b340f3 user: matt tags: v2.001
15:57
fixed get-servers-info check-in: a486adf12f user: matt tags: v2.001
15:09
wip, closer ... check-in: 38752283aa user: matt tags: v2.001
Changes

Modified dbmod.scm from [43fb4b6c81] to [fef313a73a].

5895
5896
5897
5898
5899
5900
5901
5902
5903


5904

5905
5906
5907
5908
5909
5895
5896
5897
5898
5899
5900
5901


5902
5903

5904
5905
5906
5907
5908
5909







-
-
+
+
-
+






(define (db:get-servers-info dbstruct apath)
  (db:with-db
   dbstruct
   #f #f
   (lambda (db)
     (sqlite3:fold-row
      (lambda (res count)
	(max res count))
      (lambda (res . row)
	(cons row res))
      0
      '()
      db
      "SELECT * FROM servers WHERE apath=?;"
      apath))))

)

Modified dcommon.scm from [cfabfe1da5] to [2855f6b92c].

903
904
905
906
907
908
909
910

911
912
913
914
915
916
917
903
904
905
906
907
908
909

910
911
912
913
914
915
916
917







-
+







				     #:numcol 7
				     #:numcol-visible 7
				     #:numlin-visible 5
				     ))
	 (colnames       (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "RunTime" "State" "RunId"))
	 (updater        (lambda ()
			   (if (dashboard:monitor-changed? commondat tabdat)
			       (let ((servers  (rmt:get-servers-info *remotedat* *toppath*)#;(server:get-list *toppath* limit: 10)))
			       (let ((servers  (rmt:get-servers-info *toppath*)#;(server:get-list *toppath* limit: 10)))
				 (iup:attribute-set! servers-matrix "NUMLIN" (length servers))
				 ;; (set! colnum 0)
				 ;; (for-each (lambda (colname)
				 ;;    	 ;; (print "colnum: " colnum " colname: " colname)
				 ;;    	 (iup:attribute-set! servers-matrix (conc "0:" colnum) colname)
				 ;;    	 (set! colnum (+ 1 colnum)))
				 ;;           colnames)

Modified megatest.scm from [6434fb218b] to [b3a97379d1].

1133
1134
1135
1136
1137
1138
1139
1140

1141
1142
1143
1144
1145
1146
1147
1133
1134
1135
1136
1137
1138
1139

1140
1141
1142
1143
1144
1145
1146
1147







-
+







           (adjutant-run)
           (set! *didsomething* #t)))
     
     (if (or (args:get-arg "-list-servers")
             (args:get-arg "-kill-servers"))
         (let ((tl (launch:setup)))
           (if tl ;; all roads from here exit
     	  (let* ((servers (rmt:get-servers-info *remotedat* *toppath*))
     	  (let* ((servers (rmt:get-servers-info *toppath*))
     		 (fmtstr  "~8a~22a~20a~20a~8a\n"))
	    ;; id INTEGER PRIMARY KEY,
	    ;; host TEXT,
	    ;; port INTEGER,
	    ;; servkey TEXT,
	    ;; pid TEXT,
	    ;; ipaddr TEXT,

Modified rmtmod.scm from [abf757e690] to [1621ebeda5].

2223
2224
2225
2226
2227
2228
2229
2230

2231
2232
2233
2234
2235
2236
2237
2223
2224
2225
2226
2227
2228
2229

2230
2231
2232
2233
2234
2235
2236
2237







-
+







	(rmt:wait-for-server pkts-dir dbname server-key)
	(rmt:wait-for-stable-interface))
    ;; this is our forever loop
    (let* ((iface             (servdat-host *server-info*))
	   (port              (servdat-port *server-info*)))
      (let loop ((count          0)
		 (bad-sync-count 0)
		 (start-time     (current-process-milliseconds)))
		 (start-time     (current-milliseconds)))
	(if (and (not is-main)
		 (common:low-noise-print 60 "servdat-status"))
	    (debug:print-info 0 *default-log-port* "servdat-status is " (servdat-status *server-info*)))

	;; set up the database handle
	(mutex-lock! *heartbeat-mutex*)
	(if (not *dbstruct-db*) ;; no db opened yet, open the db and register with main if appropriate
2280
2281
2282
2283
2284
2285
2286
2287

2288
2289
2290
2291
2292
2293
2294

2295
2296
2297
2298
2299
2300
2301
2280
2281
2282
2283
2284
2285
2286

2287
2288
2289
2290
2291
2292
2293

2294
2295
2296
2297
2298
2299
2300
2301







-
+






-
+







	(db:sync-inmem->disk *dbstruct-db* *toppath* dbname force-sync: #t)
	
	(mutex-unlock! *heartbeat-mutex*)
	
	;; when things go wrong we don't want to be doing the various
	;; queries too often so we strive to run this stuff only every
	;; four seconds or so.
	(let* ((sync-time (- (current-process-milliseconds) start-time))
	(let* ((sync-time (- (current-milliseconds) start-time))
	       (rem-time  (quotient (- 4000 sync-time) 1000)))
	  (if (and (<= rem-time 4)
		   (>  rem-time 0))
	      (thread-sleep! rem-time)))
	
	(if (< count 1) ;; 3x3 = 9 secs aprox
	    (loop (+ count 1) bad-sync-count (current-process-milliseconds)))
	    (loop (+ count 1) bad-sync-count (current-milliseconds)))
	
	;; Transfer *db-last-access* to last-access to use in checking that we are still alive
	(set! last-access *db-last-access*)
	
	(if (common:low-noise-print 60 "dbstats")
	    (begin
	      (debug:print 0 *default-log-port* "Server stats:")
2311
2312
2313
2314
2315
2316
2317
2318

2319
2320
2321
2322
2323
2324
2325
2311
2312
2313
2314
2315
2316
2317

2318
2319
2320
2321
2322
2323
2324
2325







-
+







	   ((and *server-run*
		 (or (not (timed-out?))
		     (if is-main ;; do not exit if there are other servers (keep main open until all others gone)
			 (> (rmt:get-count-servers remdat *toppath*) 1)
			 #f)))
	    (if (common:low-noise-print 120 "server continuing")
		(debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access)))
	    (loop 0 bad-sync-count (current-process-milliseconds)))
	    (loop 0 bad-sync-count (current-milliseconds)))
	   (else
	    (set! *unclean-shutdown* #f)
	    (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access))
	    (shutdown-server-sequence port)
	    #;(debug:print-info 0 *default-log-port* "Sending 'quit to server, received: "
			      (open-send-receive-nn (conc iface":"port)      ;; do this here and not in server-shutdown
						    (sexpr->string 'quit)))

Modified tests/unittests/server.scm from [40ab640762] to [68d25c84e5].

23
24
25
26
27
28
29

30
31
32
33


34
35
36
37
38
39
40
23
24
25
26
27
28
29
30
31
32


33
34
35
36
37
38
39
40
41







+


-
-
+
+







;;
;;  (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0)
(import rmtmod trace http-client apimod dbmod
	launchmod)

(trace-call-sites #t)
(trace
   
 ;; db:get-dbdat
 ;; rmt:find-main-server
;;  rmt:send-receive-real
;;  rmt:send-receive
 ;; rmt:send-receive-real
 ;; rmt:send-receive
 ;; sexpr->string
 ;; server-ready?
 ;; rmt:register-server
 ;;  rmt:deregister-server
 ;; rmt:open-main-connection
 ;; rmt:general-open-connection
 ;; rmt:get-conn