Megatest

Check-in [fb46b13dc5]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Cleaned up server start sequence
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | re-re-factor-server
Files: files | file ages | folders
SHA1: fb46b13dc5aabde4ee50b5b08f5e0359be806ecc
User & Date: matt on 2014-02-15 22:02:52
Other Links: branch diff | manifest | tags
Context
2014-02-15
22:41
Streamlined port sequencing for per-run db servers check-in: c6b8e8a9d8 user: matt tags: re-re-factor-server
22:02
Cleaned up server start sequence check-in: fb46b13dc5 user: matt tags: re-re-factor-server
2014-02-11
00:05
Added more files to the map check-in: a1ef0f490c user: matt tags: re-re-factor-server
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified client.scm from [7ef7342bb9] to [c71df3eef9].

︙
49
50
51
52
53
54
55
56

57
58
59
60
61
62
63

49
50
51
52
53
54
55

56
57
58
59
60
61
62
63








-
+








;; There are two scenarios. 
;;   1. We are a test manager and we received *transport-type* and *runremote* via cmdline
;;   2. We are a run tests, list runs or other interactive process and we must figure out
;;      *transport-type* and *runremote* from the monitor.db
;;
;; client:setup
;;
;; lookup_server, 
;; lookup_server, need to remove *runremote* stuff
;;
(define (client:setup run-id #!key (remaining-tries 3))
  (if (not *toppath*)
      (if (not (setup-for-run))
	  (begin
	    (debug:print 0 "ERROR: failed to find megatest.config, exiting")
	    (exit))))
︙
83
84
85
86
87
88
89



90
91
92
93
94
95
96
97
98
99
100
101
102
103














104
105
106
107
108
109
110
111

83
84
85
86
87
88
89
90
91
92














93
94
95
96
97
98
99
100
101
102
103
104
105
106

107
108
109
110
111
112
113








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








		  (begin
		    (debug:print 0 "ERROR: Expected to be able to connect to a server by now. No server available for run-id = " run-id)
		    (exit 1)))
	      (begin
		(hash-table-set! *runremote* run-id hostinfo)
		(debug:print-info 11 "CLIENT SETUP, hostinfo=" hostinfo)
		(debug:print-info 11 "Using transport type of " transport (if hostinfo (conc " to connect to " hostinfo) ""))
		(client:start run-id transport server-info)))))))

(define (client:start run-id transport server-info)
		(case *transport-type* 
		  ;; ((fs)(if (not *megatest-db*)(set! *megatest-db* (open-db))))
		  ((http)
		   ;; this saves the hostinfo in the *runremote* hash and returns it
		   (http-transport:client-connect run-id 
						  (tasks:hostinfo-get-interface hostinfo)
						  (tasks:hostinfo-get-port hostinfo)))
		  ((zmq)
		   (zmq-transport:client-connect (tasks:hostinfo-get-interface hostinfo)
						 (tasks:hostinfo-get-port      hostinfo)
						 (tasks:hostinfo-get-pubport   hostinfo)))
		  (else  ;; default to fs
		   (debug:print 0 "ERROR: unrecognised transport type " *transport-type* " exiting now.")
		   (exit)))))))))
  (case transport
    ;; ((fs)(if (not *megatest-db*)(set! *megatest-db* (open-db))))
    ((http)
     ;; this saves the server-info in the *runremote* hash and returns it
     (http-transport:client-connect run-id 
				    (tasks:hostinfo-get-interface server-info)
				    (tasks:hostinfo-get-port server-info)))
    ((zmq)
     (zmq-transport:client-connect (tasks:hostinfo-get-interface server-info)
				   (tasks:hostinfo-get-port      server-info)
				   (tasks:hostinfo-get-pubport   server-info)))
    (else  ;; default to fs
     (debug:print 0 "ERROR: unrecognised transport type " transport )
     #f)))
    ;;	  (pop-directory)))

;; client:signal-handler
(define (client:signal-handler signum)
  (handle-exceptions
   exn
   (debug:print " ... exiting ...")
   (let ((th1 (make-thread (lambda ()
︙

Modified http-transport.scm from [3967dad5c1] to [043ad30c04].

︙
390
391
392
393
394
395
396
397

398
399
400
401
402
403
404

390
391
392
393
394
395
396

397
398
399
400
401
402
403
404








-
+








	     (car login-res))
	(begin
	  (debug:print-info 2 "Logged in and connected to " iface ":" port)
	  (hash-table-set! *runremote* run-id serverdat)
	  serverdat)
	(begin
	  (debug:print-info 0 "ERROR: Failed to login or connect to " iface ":" port)
	  (exit 1)))))
	  #f))))

;; run http-transport:keep-running in a parallel thread to monitor that the db is being 
;; used and to shutdown after sometime if it is not.
;;
(define (http-transport:keep-running server-id)
  ;; if none running or if > 20 seconds since 
  ;; server last used then start shutdown
︙
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
















563
564
565

566
567
568
569
570
571
572

520
521
522
523
524
525
526






527
528
529
530
531
532
533



534
535
536

















537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552



553
554
555
556
557
558
559
560








-
-
-
-
-
-







-
-
-



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









;; all routes though here end in exit ...
;;
;; start_server? 
;;
(define (http-transport:launch run-id)
  (set! *run-id*   run-id)
  (if (not *toppath*)
      (if (not (setup-for-run))
	  (begin
	    (debug:print 0 "ERROR: cannot find megatest.config, exiting")
	    (exit))))
  (debug:print-info 2 "Starting the standalone server")
  (if (args:get-arg "-daemonize")
      (daemon:ize))
  ;;
  ;; set_available
  ;;
  (let ((server-id (open-run-close tasks:server-lock-slot tasks:open-db run-id)))
    (if (not server-id)
	;;
	;; remove_dead_entry?
	;;
	(begin
	  (debug:print-info 2 "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
	  (open-run-close tasks:server-delete-records-for-this-pid tasks:open-db))
	(if *toppath* 
	    (let* ((th2 (make-thread (lambda ()
				       (http-transport:run 
					(if (args:get-arg "-server")
					    (args:get-arg "-server")
					    "-")
					run-id
					server-id)) "Server run"))
		   (th3 (make-thread (lambda ()
				       (http-transport:keep-running server-id))
				     "Keep running")))
	      ;; Database connection
	      (set! *inmemdb*  (db:setup run-id))
	      (thread-start! th2)
	      (thread-start! th3)
	      (set! *didsomething* #t)
	      (thread-join! th2))
	(let* ((th2 (make-thread (lambda ()
				   (http-transport:run 
				    (if (args:get-arg "-server")
					(args:get-arg "-server")
					"-")
				    run-id
				    server-id)) "Server run"))
	       (th3 (make-thread (lambda ()
				   (http-transport:keep-running server-id))
				 "Keep running")))
	  ;; Database connection
	  (set! *inmemdb*  (db:setup run-id))
	  (thread-start! th2)
	  (thread-start! th3)
	  (set! *didsomething* #t)
	  (thread-join! th2)
	    (debug:print 0 "ERROR: Failed to setup for megatest")))
    ;; (sdb:qry 'finalize)
    (exit)))
	  (exit)))))

(define (http-transport:server-signal-handler signum)
  (handle-exceptions
   exn
   (debug:print " ... exiting ...")
   (let ((th1 (make-thread (lambda ()
			     (thread-sleep! 1))
︙

Modified server.scm from [a385b14a3e] to [ba9371a66f].

︙
44
45
46
47
48
49
50
51
52
53



54
55

56
57
58

59
60
61
62
63
64





65
66
67
68
69
70
71

44
45
46
47
48
49
50



51
52
53


54



55






56
57
58
59
60
61
62
63
64
65
66
67








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








;;

;; all routes though here end in exit ...
;;
;; start_server
;;
(define (server:launch transport run-id)
  (if (not *toppath*)
      (if (not (setup-for-run))
	  (begin
  (let ((server-running (server:check-if-running run-id transport)))
    (if server-running
	;; a server is already running
	    (debug:print 0 "ERROR: cannot find megatest.config, exiting")
	    (exit))))
	(exit)
  (debug:print-info 2 "Starting server using " transport " transport")
  (set! *transport-type* transport)
  (case transport
	(case transport
    ;; ((fs)   (exit)) ;; there is no "fs" server transport
    ((fs http) (http-transport:launch run-id))
    ((zmq)     (zmq-transport:launch run-id))
    (else
     (debug:print "WARNING: unrecognised transport " transport)
     (exit))))
	  ((http) (http-transport:launch run-id))
	  ((zmq)  (zmq-transport:launch run-id))
	  (else
	   (debug:print "WARNING: unrecognised transport " transport)
	   (exit))))))

;;======================================================================
;; Q U E U E   M A N A G E M E N T
;;======================================================================

;; We don't want to flush the queue if it was just flushed
(define *server:last-write-flush* (current-milliseconds))
︙
146
147
148
149
150
151
152










142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157








+
+
+
+
+
+
+
+
+

		(thread-sleep! 4)))
	  (if (< trycount 10)
	      (loop (open-run-close tasks:get-server tasks:open-db run-id) 
		    (+ trycount 1))
	      (debug:print 0 "WARNING: Couldn't start or find a server.")))
	(debug:print 2 "INFO: Server(s) running " servers)
	)))

(define (server:check-if-running run-id transport)
  (let loop ((server (open-run-close tasks:get-server tasks:open-db run-id))
	     (trycount 0))
    (if server
	;; note: client:start will set *runremote*. this needs to be changed
	;;       also, client:start will login to the server, also need to change that.
	(client:start run-id transport server)
	#f)))

This page was generated in about 0.099s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00