Megatest

Check-in [b6b960aae3]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:interim commit with partial transition to new monitor server support
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | monitor-cleanup
Files: files | file ages | folders
SHA1: b6b960aae3ec45957a3c28cb5855f182dc8b414a
User & Date: matt on 2012-10-27 16:52:45
Other Links: branch diff | manifest | tags
Context
2012-10-28
20:35
Incremental changes to monitor check-in: 372abcaa23 user: matt tags: monitor-cleanup
2012-10-27
16:52
interim commit with partial transition to new monitor server support check-in: b6b960aae3 user: matt tags: monitor-cleanup
15:24
Changed open-run-close to take a proc for db opener, #f to use open-db or an already opened db check-in: eb12585951 user: matt tags: monitor-cleanup
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified server.scm from [b66b09e982] to [0823c889a2].

︙
20
21
22
23
24
25
26





27
28
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
61
62
63

20
21
22
23
24
25
26
27
28
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
61
62
63
64
65
66
67








+
+
+
+
+


-
+
+





-
+
-
-

-
-
+
+















-
+








(declare (uses db))
(declare (uses tests))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.

(include "common_records.scm")
(include "db_records.scm")

(define (server:make-server-url hostport)
  (if (null? hostport)
      #f
      (conc "tcp://" hostname ":" port)))

(define (server:run hostn)
  (debug:print 0 "Attempting to start the server ...")
  (let ((host:port      (open-run-close db:get-var open-db "SERVER"))) ;; do whe already have a server running?
  (let* ((hostport      (open-run-close tasks:get-best-server tasks:open-db)) ;; do whe already have a server running?
	 (host:port (server:mak-server-url hostport)))
    (if host:port 
	(begin
	  (debug:print 0 "NOTE: server already running.")
	  (if (server:client-setup)
	      (begin 
		(debug:print-info 0 "Server is alive, not starting another")
		(debug:print-info 0 "Server is alive, not starting another"))
		;;(exit)
		)
	      (begin
		(debug:print-info 0 "Server is dead, removing flag and trying again")
		(open-run-close db:del-var #f "SERVER")
		(debug:print-info 0 "Server is dead, removing, deregistering it and trying again")
		(open-run-close tasks:deregister tasks:open-db (car hostport) port: (cadr port))
		(server:run hostn))))
	(let* ((zmq-socket     #f)
	       (hostname       (if (string=? "-" hostn)
				   (get-host-name) 
				   hostn))
	       (ipaddrstr      (let ((ipstr (if (string=? "-" hostn)
						(string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
						#f)))
				 (if ipstr ipstr hostname))))
	  (set! zmq-socket (server:find-free-port-and-open ipaddrstr zmq-socket 5555))
	  (set! *cache-on* #t)
	  
	  ;; what to do when we quit
	  ;;
	  (on-exit (lambda ()
		     (open-run-close db:del-var #f "SERVER")
		     (open-run-close tasks:server-deregister-self tasks:open-db)
		     (let loop () 
		       (let ((queue-len 0))
			 (thread-sleep! (random 5))
			 (mutex-lock! *incoming-mutex*)
			 (set! queue-len (length *incoming-data*))
			 (mutex-unlock! *incoming-mutex*)
			 (if (> queue-len 0)
︙
114
115
116
117
118
119
120
121

122
123
124
125
126
127
128

118
119
120
121
122
123
124

125
126
127
128
129
130
131
132








-
+








       (debug:print 0 "   EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
       (server:find-free-port-and-open host s (+ p 1)))
     (let ((zmq-url (conc "tcp://" host ":" p)))
       (print "Trying to start server on " zmq-url)
       (bind-socket s zmq-url)
       (set! *runremote* #f)
       (debug:print 0 "Server started on " zmq-url)
       (open-run-close db:set-var #f "SERVER" zmq-url)
       (open-run-close tasks:server-register tasks:open-db (current-process-id) host p 0 'live)
       s))))

(define (server:client-setup)
  (let* ((hostinfo   (open-run-close db:get-var #f "SERVER"))
	 (zmq-socket (make-socket 'req)))
    (if hostinfo
	(begin
︙

Modified tasks.scm from [4479d9da0c] to [79b4593089].

︙
69
70
71
72
73
74
75

76
77
78
79
80
81
82
83









84
85
86
87
88
89
90

69
70
71
72
73
74
75
76
77
78
79
80
81
82


83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98








+






-
-
+
+
+
+
+
+
+
+
+








	  ))
    mdb))
    
;;======================================================================
;; Server and client management
;;======================================================================

;; state: 'live, 'shutting-down, 'dead
(define (tasks:server-register mdb pid hostname port priority state)
  (sqlite3:execute 
   mdb 
   "INSERT OR REPLACE INTO servers (pid,hostname,port,start_time,priority,state) VALUES(?,?,?,strftime('%s','now'),?);"
   pid hostname port priority state))

(define (tasks:server-deregister mdb pid hostname)
  (sqlite3:execute mdb "DELETE FROM servers WHERE pid=? AND hostname=?;" pid hostname))
(define (tasks:server-deregister mdb hostname #!key (port #f)(pid #f))
  (if pid
      (sqlite3:execute mdb "DELETE FROM servers WHERE  hostname=? AND pid=?;" hostname pid)
      (if port
	  (sqlite3:execute mdb "DELETE FROM servers WHERE  hostname=? AND port=?;" hostname port)
	  (debug:print 0 "ERROR: tasks:server-deregister called with neither pid nor port specified"))))

(define (tasks:server-deregister-self mdb)
  (tasks:server-deregister mdb pid: (current-process-id) (get-host-name)))

(define (tasks:server-get-server-id mdb)
  ;; dunno yet
  0)

(define (tasks:client-register mdb pid hostname cmdline)
  (sqlite3:execute
︙
106
107
108
109
110
111
112










113
114
115
116
117
118
119

114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137








+
+
+
+
+
+
+
+
+
+








       (set! res (cons (vector id server-id pid hostname cmdline login-time lougout-time) res)))
     mdb
     "SELECT id,server_id,pid,hostname,cmdline,login_time,logout_time FROM clients WHERE server_id=?;"
     server-id)))

(define (tasks:have-clients? mdb server-id)
  (null? (tasks:get-logged-in-clients mdb server-id)))

(define (tasks:get-best-server mdb)
  (let ((res '()))
    (sqlite3:for-each-row
     (lambda (id hostname port)
       (set! res (list hostname port)))
     mdb
     "SELECT id,hostname,port FROM servers WHERE state='live' ORDER BY start_time DESC LIMIT 1;")
    res))


;;======================================================================
;; Tasks and Task monitors
;;======================================================================


;;======================================================================
︙

Modified tests/Makefile from [3b652b7f73] to [7797feb024].

︙
59
60
61
62
63
64
65
66

67
68
69
70
71
72
73

59
60
61
62
63
64
65

66
67
68
69
70
71
72
73








-
+








	cd fullrun;$(MEGATEST) -rollup :runname newrun -target ubuntu/nfs/none -debug 10


cleanprep : ../*.scm Makefile */*.config
	# if [ -e fullrun/megatest.db ]; then sqlite3 fullrun/megatest.db "delete from metadat where var='SERVER';";fi
	mkdir -p /tmp/mt_runs /tmp/mt_links
	cd ..;make install
	rm -f fullrun/logging.db
	rm -f fullrun/logging.db fullrun/monitor.db
	touch cleanprep

fullprep : cleanprep
	cd fullrun;$(MEGATEST) -server - -debug $(DEBUG) &
	sleep 5;cd fullrun;$(MEGATEST) -remove-runs :runname $(RUNNAME)% -target %/%/% -testpatt %/%
	cd fullrun;$(BINPATH)/dboard -rows 15 &
︙

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