Megatest

Check-in [5a64939577]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Fixed couple missing changes needed for server log handshaking
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | server-log-handshaking
Files: files | file ages | folders
SHA1: 5a649395770015b565caa9c55919038695cc6aca
User & Date: matt on 2017-01-28 12:25:52
Other Links: branch diff | manifest | tags
Context
2017-01-28
18:46
Fixed multiple little issues with server log handshaking check-in: cc6a49cf21 user: matt tags: server-log-handshaking
12:25
Fixed couple missing changes needed for server log handshaking check-in: 5a64939577 user: matt tags: server-log-handshaking
2017-01-27
22:47
Most needed changes made for multi-server with log handshaking. However there is a segfault ... check-in: 8a4205f90b user: matt tags: server-log-handshaking
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified dcommon.scm from [eb6ea73393] to [17ed94a823].

︙︙
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24

;;======================================================================

(use format)
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)
(import canvas-draw-iup)
(use regex typed-records)

(declare (unit dcommon))

(declare (uses megatest-version))
(declare (uses gutils))
(declare (uses db))
(declare (uses synchash))








|








10
11
12
13
14
15
16
17
18
19
20
21
22
23
24

;;======================================================================

(use format)
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)
(import canvas-draw-iup)
(use regex typed-records matchable)

(declare (unit dcommon))

(declare (uses megatest-version))
(declare (uses gutils))
(declare (uses db))
(declare (uses synchash))
︙︙
618
619
620
621
622
623
624

625
626
627
628
629
630
631
632
633
634
635
636






637
638
639
640
641
642
643
644

645
646
647
648

649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669

				     #: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 (tasks:get-all-servers (db:delay-if-busy tdbdat))))
				 (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)
				 (set! rownum 1)
				 (for-each 
				  (lambda (server)
				    (set! colnum 0)






				    (let* ((vals (list (vector-ref server 0) ;; Id
						       (vector-ref server 9) ;; MT-Ver
						       (vector-ref server 1) ;; Pid
						       (vector-ref server 2) ;; Hostname
						       (conc (vector-ref server 3) ":" (vector-ref server 4)) ;; IP:Port
						       (seconds->hr-min-sec (- (current-seconds)(vector-ref server 6)))
						       ;; (vector-ref server 5) ;; Pubport
						       ;; (vector-ref server 10) ;; Last beat

						       ;; (vector-ref server 6) ;; Start time
						       ;; (vector-ref server 7) ;; Priority
						       ;; (vector-ref server 8) ;; State
						       (vector-ref server 8) ;; State

						       (vector-ref server 12)  ;; RunId
						       )))
				      (for-each (lambda (val)
						  (let* ((row-col (conc rownum ":" colnum))
							 (curr-val (iup:attribute servers-matrix row-col)))
						    (if (not (equal? (conc val) curr-val))
							(begin
							  (iup:attribute-set! servers-matrix row-col val)
							  (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum))))
						    (set! colnum (+ 1 colnum))))
						vals)
				      (set! rownum (+ rownum 1)))
				    (iup:attribute-set! servers-matrix "REDRAW" "ALL"))
				  servers))))))
    (set! colnum 0)
    (for-each (lambda (colname)
		(iup:attribute-set! servers-matrix (conc "0:" colnum) colname)
		(iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum))
		(set! colnum (+ colnum 1)))
	      colnames)
    ;; (set! dashboard:update-servers-table updater) 








>
|











>
>
>
>
>
>
|
|
|
|
|
<
|
<
>
|
<
<
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|








618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648

649

650
651


652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674

				     #: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  (server:get-list *toppath*)))
				 ;; (tasks:get-all-servers (db:delay-if-busy tdbdat))))
				 (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)
				 (set! rownum 1)
				 (for-each 
				  (lambda (server)
				    (set! colnum 0)
				    (match-let (((mod-time host port start-time pid)
						 server))
				      (let* ((uptime  (- (current-seconds) mod-time))
					     (runtime (if start-time
							  (- (current-seconds) start-time)
							  0))
					     (vals (list "-"  ;; (vector-ref server 0) ;; Id
							 "-"  ;; (vector-ref server 9) ;; MT-Ver
							 pid  ;; (vector-ref server 1) ;; Pid
							 host ;; (vector-ref server 2) ;; Hostname
							 (conc host ":" port) ;; (conc (vector-ref server 3) ":" (vector-ref server 4)) ;; IP:Port

							 (seconds->hr-min-sec runtime) ;; (- (current-seconds) start-time)) ;; (vector-ref server 6)))

							 (cond
							  ((< uptime 5)  "alive")


							  ((< uptime 16) "probably alive");; less than 15 seconds since mod, call it alive (vector-ref server 8) ;; State
							  (else "dead"))
							 "-" ;; (vector-ref server 12)  ;; RunId
							 )))
					(for-each (lambda (val)
						    (let* ((row-col (conc rownum ":" colnum))
							   (curr-val (iup:attribute servers-matrix row-col)))
						      (if (not (equal? (conc val) curr-val))
							  (begin
							    (iup:attribute-set! servers-matrix row-col val)
							    (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum))))
						      (set! colnum (+ 1 colnum))))
						  vals)
					(set! rownum (+ rownum 1)))
				      (iup:attribute-set! servers-matrix "REDRAW" "ALL")))
				    (sort servers (lambda (a b)(< (car a)(car b))))))))))
    (set! colnum 0)
    (for-each (lambda (colname)
		(iup:attribute-set! servers-matrix (conc "0:" colnum) colname)
		(iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum))
		(set! colnum (+ colnum 1)))
	      colnames)
    ;; (set! dashboard:update-servers-table updater)
︙︙

Modified server.scm from [81e0620ae8] to [0aa5a0a335].

︙︙
160
161
162
163
164
165
166
167
168
169
170



171









172
173
174
175
176
177
178

		    (let ((dat  (cdr mlst)))
		      (list (car dat) ;; host
			    (string->number (cadr dat)) ;; port
			    (string->number (caddr dat))))))
	      (list #f #f #f)))))))

;; get a list of servers with all relevant data
;; ( mod-time host port start-time )
;;
(define (server:get-list areapath)
  (let ((fname-rx (regexp "^(|.*/)server-(\\d+)-(\\S+).log$")))



    (if (directory-exists? areapath)









	(let ((server-logs (glob (conc areapath "/logs/server-*.log"))))
	  (if (null? server-logs)
	      '()
	      (let loop ((hed  (car server-logs))
			 (tal  (cdr server-logs))
			 (res '()))
		(let* ((mod-time (file-modification-time hed))








|



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








160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190

		    (let ((dat  (cdr mlst)))
		      (list (car dat) ;; host
			    (string->number (cadr dat)) ;; port
			    (string->number (caddr dat))))))
	      (list #f #f #f)))))))

;; get a list of servers with all relevant data
;; ( mod-time host port start-time pid )
;;
(define (server:get-list areapath)
  (let ((fname-rx (regexp "^(|.*/)server-(\\d+)-(\\S+).log$")))
    ;; if the directory exists continue to get the list
    ;; otherwise attempt to create the logs dir and then
    ;; continue
    (if (if (directory-exists? (conc areapath "/logs"))
	    #t
	    (if (file-write-access? areapath)
		(begin
		  (condition-case
		      (create-directory (conc areapath "/logs") #t)
		    (exn (i/o file)(debug:print 0 *default-log-port* "ERROR: Cannot create directory at " (conc areapath "/logs")))
		    (exn ()(debug:print 0 *default-log-port* "ERROR: Unknown error attemtping to get server list.")))
		  (directory-exists? (conc areapath "/logs")))
		#f))
	(let ((server-logs (glob (conc areapath "/logs/server-*.log"))))
	  (if (null? server-logs)
	      '()
	      (let loop ((hed  (car server-logs))
			 (tal  (cdr server-logs))
			 (res '()))
		(let* ((mod-time (file-modification-time hed))
︙︙
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377

	    (> (- (current-seconds) last-run-time) 30))
	(begin
	  (server:run areapath)
	  (hash-table-set! *server-kind-run* areapath (current-seconds))))))

(define server:try-running server:run) ;; there is no more per-run servers ;; REMOVE ME. BUG.

;; (define (server:attempting-start areapath)
;;   (with-output-to-file
;;       (conc areapath "/.starting-server")
;;     (lambda ()
;;       (print (current-process-id) " on " (get-host-name)))))
;;   
;; (define (server:complete-attempt areapath)
;;   (delete-file* (conc areapath "/.starting-server")))
;;   
;; (define (server:start-attempted? areapath)
;;   (let ((flagfile (conc areapath "/.starting-server")))
;;     (handle-exceptions
;;      exn
;;      #f  ;; if things go wrong pretend we can't see the file
;;      (cond
;;       ((and (file-exists? flagfile)
;;             (< (- (current-seconds)
;;                   (file-modification-time flagfile))
;;                15)) ;; exists and less than 15 seconds old
;;        (with-input-from-file flagfile (lambda () (read-line))))
;;       ((file-exists? flagfile) ;; it is stale.
;;        (server:complete-attempt areapath)
;;        #f)
;;       (else #f)))))
;; 
;; (define (server:read-dotserver areapath)
;;   (let ((dotfile (conc areapath "/.server")))
;;     (handle-exceptions
;;      exn
;;      #f  ;; if things go wrong pretend we can't see the file
;;      (cond
;;       ((not (file-exists? dotfile))
;;        #f)
;;       ((not (file-read-access? dotfile))
;;        #f)
;;       ((> (server:dotserver-age-seconds areapath) (+ 5 (server:get-timeout)))
;;        (server:remove-dotserver-file areapath ".*")
;;        #f)
;;       (else
;;        (let* ((line
;;                (with-input-from-file
;;                    dotfile
;;                  (lambda ()
;;                    (read-line))))
;;               (tokens (if (string? line) (string-split line ":") #f)))
;;          (cond
;;           ((eq? 4 (length tokens))
;;            tokens)
;;           (else #f))))))))
;;        
;; (define (server:read-dotserver->url areapath)
;;   (let ((dotserver-tokens (server:read-dotserver areapath)))
;;     (if dotserver-tokens
;;         (conc (list-ref dotserver-tokens 0) ":" (list-ref dotserver-tokens 1))
;; #f)))
;; 
;; ;; write a .server file in *toppath* with hostport
;; ;; return #t on success, #f otherwise
;; ;;
;; (define (server:write-dotserver areapath host port pid transport)
;;   (let ((lock-file   (conc areapath "/.server.lock"))
;; 	(server-file (conc areapath "/.server")))
;;     (if (common:simple-file-lock lock-file)
;; 	(let ((res (handle-exceptions
;; 		    exn
;; 		    #f ;; failed for some reason, for the moment simply return #f
;; 		    (with-output-to-file server-file
;; 		      (lambda ()
;; 			(print (conc host ":" port ":" pid ":" transport))))
;; 		    #t)))
;; 	  (debug:print-info 0 *default-log-port* "server file " server-file " for " host ":" port " created pid="pid)
;; 	  (common:simple-file-release-lock lock-file)
;; 	  res)
;; 	#f)))
;; 
;; 
;; ;; this will check that the .server file present matches the server calling this procedure.
;; ;; if parameters match (this-pid and transport) the file will be touched and #t returned
;; ;; otherwise #f will be returned.
;; (define (server:confirm-dotserver areapath this-iface this-port this-pid this-transport)
;;   (let* ((tokens (server:read-dotserver areapath)))
;;     (cond
;;      ((not tokens)
;;       (debug:print-info 0 *default-log-port* "INFO: .server file does not exist.")
;;       #f)
;;      ((not (eq? 4 (length tokens)))
;;       (debug:print-info 0 *default-log-port* "INFO: .server file is corrupt.  There are not 4 tokens as expeted; there are "(length tokens)".")
;;       #f)
;;      ((not (equal? this-iface (list-ref tokens 0)))
;;       (debug:print-info 0 *default-log-port* "INFO: .server file mismatch.  for iface, server has value >"(list-ref tokens 0)"< but this server's value is >"this-iface"<")
;;       #f)
;;      ((not (equal? (->string this-port)  (list-ref tokens 1)))
;;       (debug:print-info 0 *default-log-port* "INFO: .server file mismatch.  for port, .server has value >"(list-ref tokens 1)"< but this server's value is >"(->string this-port)"<")
;;       #f)
;;      ((not (equal? (->string this-pid)   (list-ref tokens 2)))
;;       (debug:print-info 0 *default-log-port* "INFO: .server file mismatch.  for pid, .server has value >"(list-ref tokens 2)"< but this server's value is >"(->string this-pid)"<")
;;       #f)
;;      ((not (equal? (->string this-transport) (->string (list-ref tokens 3))))
;;       (debug:print-info 0 *default-log-port* "INFO: .server file mismatch.  for transport, .server has value >"(list-ref tokens 3)"< but this server's value is >"this-transport"<")
;;       #f)
;;      (else (server:touch-dotserver areapath)
;;       #t))))
;; 
;; (define (server:touch-dotserver areapath)
;;   (let ((server-file (conc areapath "/.server")))
;;     (change-file-times server-file (current-seconds) (current-seconds))))

(define (server:dotserver-age-seconds areapath)
  (let ((server-file (conc areapath "/.server")))
    (begin
      (handle-exceptions
       exn
       #f
       (- (current-seconds)
          (file-modification-time server-file))))))
    
;; (define (server:remove-dotserver-file areapath hostport)
;;   (let ((dotserver-url   (server:read-dotserver->url areapath))
;; 	(server-file (conc areapath "/.server"))
;; 	(lock-file   (conc areapath "/.server.lock")))
;;     (if (and dotserver-url (string-match (conc ".*:" hostport "$") dotserver-url)) ;; port matches, good enough info to decide to remove the file
;; 	(if (common:simple-file-lock lock-file)
;; 	    (begin
;; 	      (handle-exceptions
;; 	       exn
;; 	       #f
;; 	       (delete-file* server-file))
;; 	      (debug:print-info 0 *default-log-port* "server file " server-file " for " hostport " removed")
;; 	      (common:simple-file-release-lock lock-file))
;;             (debug:print-info 0 *default-log-port* "server file " server-file " for " hostport " NOT removed - could not get lock."))
;;         (debug:print-info 0 *default-log-port* "server file " server-file " for " hostport " NOT removed - dotserver-url("dotserver-url") did not match hostport pattern ("hostport")"))))

;; no longer care if multiple servers are started by accident. older servers will drop off in time.
;;
(define (server:check-if-running areapath)
  (let* ((servers       (server:get-best (server:get-list areapath)))
	 (best-server   (if (null? servers) #f (car servers)))
	 (dotserver-url (if best-server
			    (server:record->url best-server)








<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<









<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








244
245
246
247
248
249
250











































































































251
252
253
254
255
256
257
258
259
















260
261
262
263
264
265
266

	    (> (- (current-seconds) last-run-time) 30))
	(begin
	  (server:run areapath)
	  (hash-table-set! *server-kind-run* areapath (current-seconds))))))

(define server:try-running server:run) ;; there is no more per-run servers ;; REMOVE ME. BUG.












































































































(define (server:dotserver-age-seconds areapath)
  (let ((server-file (conc areapath "/.server")))
    (begin
      (handle-exceptions
       exn
       #f
       (- (current-seconds)
          (file-modification-time server-file))))))
    
















;; no longer care if multiple servers are started by accident. older servers will drop off in time.
;;
(define (server:check-if-running areapath)
  (let* ((servers       (server:get-best (server:get-list areapath)))
	 (best-server   (if (null? servers) #f (car servers)))
	 (dotserver-url (if best-server
			    (server:record->url best-server)
︙︙

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