Megatest

Check-in [448f45b91b]
Login
Overview
Comment:Some updates from code review
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.80
Files: files | file ages | folders
SHA1: 448f45b91b3ce48a246f73f80677367e0f4da489
User & Date: mrwellan on 2023-04-10 16:16:10
Other Links: branch diff | manifest | tags
Context
2023-04-10
19:36
Improved run away server throttling check-in: 4115ca72bc user: matt tags: v1.80
16:16
Some updates from code review check-in: 448f45b91b user: mrwellan tags: v1.80
11:58
Merged fork check-in: 962cf22780 user: mrwellan tags: v1.80
Changes

Modified tcp-transportmod.scm from [456ca5eb0a] to [4f582ce483].

152
153
154
155
156
157
158
159
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
			   port: port
			   host-port: host-port
			   dbfname: dbfname
			   servinf-file: servinffile
			   server-id: server-id
			   server-start: start-time
			   pid: pid)))
	       (hash-table-set! (tt-conns ttdat) dbfname conn)
	       ;; verify we can talk to this server
	       (let* ((ping-res (tt:ping host port server-id)))
		 (case ping-res
		   ((running) conn)


		   ((starting)
		    (thread-sleep! 0.5)
		    (tt:client-connect-to-server ttdat dbfname run-id testsuite))
		   (else
		    (let* ((curr-secs (current-seconds)))
		      ;; rm the (last server) would go here
		      (if (> (- curr-secs (tt-last-serv-start ttdat)) 10)
			  (begin
			    (tt-last-serv-start-set! ttdat curr-secs)
			    (server-start-proc))) ;; start server if 30 sec since last attempt
		      (thread-sleep! 1)
		      (tt:client-connect-to-server ttdat dbfname run-id testsuite)))))))
		   
	    (else
	     (if (> (- (current-seconds) (tt-last-serv-start ttdat)) 5) ;; really do not want to swamp the machine with servers
		 (begin
		   (debug:print-info 0 *default-log-port* "No server found. Starting one for run-id "run-id" in dbfile "dbfname)
		   (server-start-proc)
		   (tt-last-serv-start-set! ttdat (current-seconds))))
	     (thread-sleep! 1)
	     (tt:client-connect-to-server ttdat dbfname run-id testsuite)))))))








<



|
>
>












|
<
|







152
153
154
155
156
157
158

159
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
			   port: port
			   host-port: host-port
			   dbfname: dbfname
			   servinf-file: servinffile
			   server-id: server-id
			   server-start: start-time
			   pid: pid)))

	       ;; verify we can talk to this server
	       (let* ((ping-res (tt:ping host port server-id)))
		 (case ping-res
		   ((running)
		    (hash-table-set! (tt-conns ttdat) dbfname conn) ;;; is this ok to save before validating that the connection is good?
		    conn)
		   ((starting)
		    (thread-sleep! 0.5)
		    (tt:client-connect-to-server ttdat dbfname run-id testsuite))
		   (else
		    (let* ((curr-secs (current-seconds)))
		      ;; rm the (last server) would go here
		      (if (> (- curr-secs (tt-last-serv-start ttdat)) 10)
			  (begin
			    (tt-last-serv-start-set! ttdat curr-secs)
			    (server-start-proc))) ;; start server if 30 sec since last attempt
		      (thread-sleep! 1)
		      (tt:client-connect-to-server ttdat dbfname run-id testsuite)))))))
	    (else ;; no good server found, if haven't started server in > 5 secs, start another

	     (if (> (- (current-seconds) (tt-last-serv-start ttdat)) 5) ;; BUG - grow this number really do not want to swamp the machine with servers
		 (begin
		   (debug:print-info 0 *default-log-port* "No server found. Starting one for run-id "run-id" in dbfile "dbfname)
		   (server-start-proc)
		   (tt-last-serv-start-set! ttdat (current-seconds))))
	     (thread-sleep! 1)
	     (tt:client-connect-to-server ttdat dbfname run-id testsuite)))))))

742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769

770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
;;======================================================================

;; find a port and start tcp-server. This only starts the tcp portion of
;; the server, look at (tt:start-server ...) above for the entry point
;; for the entire server system
;;
(define (tt:start-tcp-server ttdat)
  (setup-listener-portlogger ttdat)
  (let* ((socket   (tt-socket  ttdat))
	 (handler  (tt-handler ttdat))
	 (handler-proc (lambda ()
			 (let* ((indat         (deserialize))
				(result        #f)
				(exn-result    #f)
				(stdout-result (with-output-to-string
						 (lambda ()
						   (let ((res (handle-exceptions
								  exn
								(let* ((errdat (condition->list exn)))
								  (set! exn-result errdat)
								  (debug:print 0 *default-log-port* "ERROR: handler exception, these are bad, will exit in five seconds.")
								  (pp errdat *default-log-port*)
								  ;; these are always bad, set up an exit thread
								  (thread-start! (make-thread (lambda ()
												(thread-sleep! 5)
												(exit))))
								  #f)
								(handler indat))))

						     (set! result res)))))
				(full-result (list result exn-result (if (equal? stdout-result "") #f stdout-result))))
			   (handle-exceptions
			       exn
			     (begin
			       (debug:print 0 *default-log-port* "Serialization failure. full-result="full-result)
			       ;; (serialize '(#f #f #f)) ;; doesn't work - the first call to serialize caused failure
			       )
			     (serialize full-result))))))
    ((make-tcp-server socket handler-proc)
     #f ;; yes, send error messages to std-err
     )))

;; create a tcp listener and return a populated udat struct with
;; my port, address, hostname, pid etc.
;; return #f if fail to find a port to allocate.
;;
;;  if udata-in is #f create the record
;;  if there is already a serv-listener return the udata
;;
(define (setup-listener uconn #!optional (port 4242))
  (assert (tt? uconn) "FATAL: setup-listener called with wrong struct "uconn)
  (handle-exceptions
   exn
   (if (< port 65535)
       (begin
	 (thread-sleep! 0.25)
	 (setup-listener uconn (+ port 1)))
       #f)
   (connect-listener uconn port)))

(define (setup-listener-portlogger uconn)
  (let ((port (portlogger:open-run-close portlogger:find-port)))
    (assert (tt? uconn) "FATAL: setup-listener called with wrong struct "uconn)
    (handle-exceptions
	exn
      (if (< port 65535)







|

|

















|
>




















|
|
|
|
|
|
|
|
|
|







742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
;;======================================================================

;; find a port and start tcp-server. This only starts the tcp portion of
;; the server, look at (tt:start-server ...) above for the entry point
;; for the entire server system
;;
(define (tt:start-tcp-server ttdat)
  (setup-listener-portlogger ttdat) ;; set up tcp-listener
  (let* ((socket   (tt-socket  ttdat))
	 (handler  (tt-handler ttdat)) ;; the handler comes from our client setting a handler function
	 (handler-proc (lambda ()
			 (let* ((indat         (deserialize))
				(result        #f)
				(exn-result    #f)
				(stdout-result (with-output-to-string
						 (lambda ()
						   (let ((res (handle-exceptions
								  exn
								(let* ((errdat (condition->list exn)))
								  (set! exn-result errdat)
								  (debug:print 0 *default-log-port* "ERROR: handler exception, these are bad, will exit in five seconds.")
								  (pp errdat *default-log-port*)
								  ;; these are always bad, set up an exit thread
								  (thread-start! (make-thread (lambda ()
												(thread-sleep! 5)
												(exit))))
								  #f)
								(handler indat) ;; this is the proc being called by the remote client
								)))
						     (set! result res)))))
				(full-result (list result exn-result (if (equal? stdout-result "") #f stdout-result))))
			   (handle-exceptions
			       exn
			     (begin
			       (debug:print 0 *default-log-port* "Serialization failure. full-result="full-result)
			       ;; (serialize '(#f #f #f)) ;; doesn't work - the first call to serialize caused failure
			       )
			     (serialize full-result))))))
    ((make-tcp-server socket handler-proc)
     #f ;; yes, send error messages to std-err
     )))

;; create a tcp listener and return a populated udat struct with
;; my port, address, hostname, pid etc.
;; return #f if fail to find a port to allocate.
;;
;;  if udata-in is #f create the record
;;  if there is already a serv-listener return the udata
;;
;; (define (setup-listener uconn #!optional (port 4242))
;;   (assert (tt? uconn) "FATAL: setup-listener called with wrong struct "uconn)
;;   (handle-exceptions
;;    exn
;;    (if (< port 65535)
;;        (begin
;; 	 (thread-sleep! 0.25)
;; 	 (setup-listener uconn (+ port 1)))
;;        #f)
;;    (connect-listener uconn port)))

(define (setup-listener-portlogger uconn)
  (let ((port (portlogger:open-run-close portlogger:find-port)))
    (assert (tt? uconn) "FATAL: setup-listener called with wrong struct "uconn)
    (handle-exceptions
	exn
      (if (< port 65535)

Modified utils/plot-code.scm from [2b6e0cd992] to [692dd68f5f].

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
;; Coming soon (right?) Usage: plot-code file1.scm,file2.scm "fun1,fun2,x*" *.scm > plot.dot
;; Usage: plot-code file1.scm,file2.scm *.scm > plot.dot
;;        dot -Tpdf plot.dot > plot.pdf
;; first param is comma separated list of files to include in the map, use - to do all
;; second param is list of regexs for functions to include in the map
;; third param is list of files to scan

(use regex srfi-69 srfi-13)









(define targs #f) 


(define files (cdr (cddddr (argv))))












(let ((targdat (cadddr (argv))))
  (if (equal? targdat "-")
      (set! targs files)
      (set! targs (string-split targdat ","))))

(define function-patt (car (cdr (cdddr (argv)))))
(define function-rx   (regexp function-patt))
(define filedat-defns (make-hash-table))
(define filedat-usages (make-hash-table))

(define defn-rx (regexp "^\\s*\\(define\\s+\\(([^\\s\\)]+).*"))
(define all-regexs (make-hash-table))








|

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

>
>
|
|
|
|

<







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
;; Coming soon (right?) Usage: plot-code file1.scm,file2.scm "fun1,fun2,x*" *.scm > plot.dot
;; Usage: plot-code file1.scm,file2.scm *.scm > plot.dot
;;        dot -Tpdf plot.dot > plot.pdf
;; first param is comma separated list of files to include in the map, use - to do all
;; second param is list of regexs for functions to include in the map
;; third param is list of files to scan

;; (use regex srfi-69 srfi-1 srfi-13)

(module plot-code
	*

(import scheme chicken.base chicken.port chicken.string chicken.io)
(import chicken.process-context)	
(import	regex srfi-1 srfi-69 srfi-13 matchable)

(define files #f)
(define targs #f)
(define function-patt #f)
(define targs #f) 

(match (command-line-arguments)
       ((targfiles fnrx . scanfiles)
	(set! targs (string-split-fields "," targfiles #:infix))
	(set! function-patt fnrx)
	(set! files scanfiles))
       (else
	(print "Usage: plot-code file1.scm,file2.scm *.scm > plot.dot
 dot -Tpdf plot.dot > plot.pdf")
	(exit)))

;; (define files (cdr (cddddr (argv))))
;; 
;; (let ((targdat (cadddr (argv))))
;;   (if (equal? targdat "-")
;;       (set! targs files)
;;       (set! targs (string-split targdat ","))))


(define function-rx   (regexp function-patt))
(define filedat-defns (make-hash-table))
(define filedat-usages (make-hash-table))

(define defn-rx (regexp "^\\s*\\(define\\s+\\(([^\\s\\)]+).*"))
(define all-regexs (make-hash-table))

195
196
197
198
199
200
201

	       "\"" fnname "\" -> \"" callname "\";"))
      calls)))
 function-calls)

(print "}")

(exit)








>
215
216
217
218
219
220
221
222
	       "\"" fnname "\" -> \"" callname "\";"))
      calls)))
 function-calls)

(print "}")

(exit)
)