Megatest

Check-in [743e63bc9e]
Login
Overview
Comment:server registation and timeout working
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.80-tcp-inmem
Files: files | file ages | folders
SHA1: 743e63bc9e09bfdfc16322c4f6f28b2051b3f186
User & Date: matt on 2023-02-18 20:32:06
Other Links: branch diff | manifest | tags
Context
2023-02-19
10:37
rmt:send-receive -> tt:handler -> tcp -> api:tcp-dispatch-request -> api:dispatch-request and back implemented and compiles. check-in: a91d15ac06 user: matt tags: v1.80-tcp-inmem
2023-02-18
20:32
server registation and timeout working check-in: 743e63bc9e user: matt tags: v1.80-tcp-inmem
2023-02-17
06:02
Merged fork check-in: f756aa00cd user: matt tags: v1.80-tcp-inmem
Changes

Modified tcp-transportmod.scm from [c233cd9055] to [d835b7f23a].

64
65
66
67
68
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
99
100
101
102

;;======================================================================
;; client
;;======================================================================

;; (define keep-age-param (make-parameter 10)) ;; qif file age, if over move to attic



(defstruct tt-conn
  host
  port
  host-port
  dbfname
  server-id
  server-start
  pid
)


(defstruct tt
  ;; client related
  (conns (make-hash-table)) ;; dbfname -> conn

  ;; server related
  (areapath     #f)
  (host         #f)
  (port         #f)
  (conn         #f)
  (cleanup-proc #f)
  (handler      #f) ;; receives data and responds
  (socket       #f)
  (thread       #f)
  (host-port    #f)
  (cmd-thread   #f)

  )

(define (tt:make-remote areapath)
  (make-tt area: areapath))

;; do all the busy work of finding and setting up conn for
;; connecting to a server







>
>










>















>







64
65
66
67
68
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
99
100
101
102
103
104
105
106

;;======================================================================
;; client
;;======================================================================

;; (define keep-age-param (make-parameter 10)) ;; qif file age, if over move to attic

;; Used ONLY for client
;;
(defstruct tt-conn
  host
  port
  host-port
  dbfname
  server-id
  server-start
  pid
)

;; Used for BOTH clients and servers
(defstruct tt
  ;; client related
  (conns (make-hash-table)) ;; dbfname -> conn

  ;; server related
  (areapath     #f)
  (host         #f)
  (port         #f)
  (conn         #f)
  (cleanup-proc #f)
  (handler      #f) ;; receives data and responds
  (socket       #f)
  (thread       #f)
  (host-port    #f)
  (cmd-thread   #f)
  (last-access  (current-seconds))
  )

(define (tt:make-remote areapath)
  (make-tt area: areapath))

;; do all the busy work of finding and setting up conn for
;; connecting to a server
193
194
195
196
197
198
199


200
201
202
203
204
205
206


207



208















209
210
211
212
213
214
215



















216
217
218
219
220
221
222
223
  #f)

;; start the listener and start responding to requests
;;
;; NOTE: organise by dbfname, not run-id so we don't need
;;       to pull in more modules
;;


(define (tt:start-server areapath run-id dbfname handler)
  ;; is there already a server for this dbfile? Then exit.
  (let* ((ttdat  (make-tt areapath: areapath))
	 (servers (tt:find-server ttdat dbfname)))
    (tt-handler-set! ttdat handler)
    (if (null? servers)
	(let* ((dbstruct (dbmod:open-dbmoddb areapath run-id (dbfile:db-init-proc))))


	  (tt:start-tcp-server ttdat) ;; start the tcp-server which applies handler to incoming data



	  (tt:keep-running ttdat dbfname handler))















	(begin
	  (debug:print 0 *default-log-port* "INFO: found server(s) already running for db "dbfname", "(string-intersperse servers ",")" Exiting.")
	  (exit)))))

(define (tt:keep-running ttdat dbfile)
  ;; verfiy conn for ready
  ;; listener socket has been started by this stage



















  (debug:print 0 *default-log-port* "INFO: Got here!!!!"))

;; ;; given an already set up uconn start the cmd-loop
;; ;;
;; (define (tt:cmd-loop ttdat)
;;   (let* ((serv-listener (-socket uconn))
;; 	 (listener      (lambda ()
;; 			  (let loop ((state 'start))







>
>


|



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




|


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







197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
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
  #f)

;; start the listener and start responding to requests
;;
;; NOTE: organise by dbfname, not run-id so we don't need
;;       to pull in more modules
;;
;; This is the routine called in megatest.scm to start a server
;;
(define (tt:start-server areapath run-id dbfname handler)
  ;; is there already a server for this dbfile? Then exit.
  (let* ((ttdat   (make-tt areapath: areapath))
	 (servers (tt:find-server ttdat dbfname)))
    (tt-handler-set! ttdat handler)
    (if (null? servers)
	(let* ((dbstruct   (dbmod:open-dbmoddb areapath run-id (dbfile:db-init-proc)))
	       (tcp-thread (make-thread
			    (lambda ()
			      (tt:start-tcp-server ttdat)) ;; start the tcp-server which applies handler to incoming data
			    "tcp-server-thread"))
	       (run-thread (make-thread
			    (lambda ()
			      (tt:keep-running ttdat dbfname)))))
	  (thread-start! tcp-thread)
	  (thread-start! run-thread)
	  (thread-join! run-thread) ;; run thread will exit on timeout or other conditions
	  ;;
	  ;; set a flag here to tell tcp-thread to stop running
	  ;;
	  ;; (thread-join! tcp-thread) ;; can't wait 
	  ;;
	  ;; remove the servinfo file
	  ;;
	  ;; close the database, remove lock in on-disk db
	  ;;
	  ;; close the listener ports
	  ;;
	  (exit))
	(begin
	  (debug:print 0 *default-log-port* "INFO: found server(s) already running for db "dbfname", "(string-intersperse servers ",")" Exiting.")
	  (exit)))))

(define (tt:keep-running ttdat dbfname)
  ;; verfiy conn for ready
  ;; listener socket has been started by this stage
  (thread-sleep! 1)
  (let loop ((count 0))
    (if (> count 60)
	(begin
	  (debug:print 0 *default-log-port* "FATAL: Could not start a tcp server, giving up.")
	  (exit 1))
	(if (not (tt-port ttdat)) ;; no connection yet
	    (begin
	      (thread-sleep! 1)
	      (loop (+ count 1))))))
  
  (tt:create-server-registration-file ttdat dbfname)
  ;; now start watching the last-access, if it hasn't been touched
  ;; in over ten seconds we exit
  (let loop ()
    (if (< (- (current-seconds) (tt-last-access ttdat)) 10)
	(begin
	  (thread-sleep! 2)
	  (loop))))
  (debug:print 0 *default-log-port* "INFO: Server timed out, exiting."))

;; ;; given an already set up uconn start the cmd-loop
;; ;;
;; (define (tt:cmd-loop ttdat)
;;   (let* ((serv-listener (-socket uconn))
;; 	 (listener      (lambda ()
;; 			  (let loop ((state 'start))
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

;; return servid
;; side-effects:
;;   ttdat-cleanup-proc is populated with function to remove the serverinfo file
(define (tt:create-server-registration-file ttdat dbfname)
  (let* ((areapath (tt-areapath ttdat))
	 (servdir  (tt:get-servinfo-dir areapath))
	 (conn     (hash-table-ref/default (tt-conns ttdat) dbfname #f)))
    (assert conn "FATAL: tt:create-server-registration-file called with no conn, dbfname="dbfname)
    (let* ((host    (tt-conn-host conn))
	   (port    (tt-conn-port conn))
	   (servinf (conc servdir"/"host":"port"-"(current-process-id)":"dbfname))
	   (serv-id (tt:mk-signature areapath))
	   (clean-proc (lambda ()
			 (delete-file* servinf))))

      (tt-cleanup-proc-set! ttdat clean-proc)
      (with-output-to-file servinf
	(lambda ()
	  (print "SERVER STARTED: "host":"port" AT "(current-seconds)" server-id: "serv-id" pid: "(current-process-id)" dbfname: "dbfname)))
      serv-id)))

;; find valid server
;; get servers listed, last part of name must match :<dbfname>
;; if more than one, wait one second and look again
;; future: ping oldest, if alive remove other :<dbfname> files
;;
(define (tt:find-server ttdat dbfname)







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







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

;; return servid
;; side-effects:
;;   ttdat-cleanup-proc is populated with function to remove the serverinfo file
(define (tt:create-server-registration-file ttdat dbfname)
  (let* ((areapath (tt-areapath ttdat))
	 (servdir  (tt:get-servinfo-dir areapath))


	 (host     (tt-host ttdat))
	 (port     (tt-port ttdat))
	 (servinf (conc servdir"/"host":"port"-"(current-process-id)":"dbfname))
	 (serv-id (tt:mk-signature areapath))
	 (clean-proc (lambda ()
		       (delete-file* servinf))))
    (assert (and host port) "FATAL: tt:create-server-registration-file called with no conn, dbfname="dbfname)
    (tt-cleanup-proc-set! ttdat clean-proc)
    (with-output-to-file servinf
      (lambda ()
	(print "SERVER STARTED: "host":"port" AT "(current-seconds)" server-id: "serv-id" pid: "(current-process-id)" dbfname: "dbfname)))
      serv-id))

;; find valid server
;; get servers listed, last part of name must match :<dbfname>
;; if more than one, wait one second and look again
;; future: ping oldest, if alive remove other :<dbfname> files
;;
(define (tt:find-server ttdat dbfname)
360
361
362
363
364
365
366












367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399

400
401
402
403
404
405
406
    (debug:print 0 *default-log-port* "INFO: starting server at " (common:human-time))
    (system (conc "nbfake " cmdln))
    (pop-directory)))

;;======================================================================
;; tcp connection stuff
;;======================================================================













;; 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)
       (setup-listener uconn (+ port 1))
       #f)
   (connect-listener uconn port)))

;; find a port and start tcp-server
;;
(define (tt:start-tcp-server ttdat)
  (setup-listener ttdat)
  (let* ((socket   (tt-socket ttdat))
	 (handler  (tt-handler    ttdat)))
    ((make-tcp-server socket handler)
     #t ;; yes, send error messages to std-err
     )))

(define (connect-listener uconn port)
  ;; (tcp-listener-socket LISTENER)(socket-name so)
  ;; sockaddr-address, sockaddr-port, sockaddr->string
  (let* ((tlsn (tcp-listen port 1000 #f)) ;; (tcp-listen TCPPORT [BACKLOG [HOST]])
	 (addr  (tt:get-best-guess-address (get-host-name)))) ;; (get-my-best-address))) ;; (hostinfo-addresses (host-information (current-hostname)))
    (tt-port-set!      uconn port)

    (tt-host-port-set! uconn (conc addr":"port))
    (tt-socket-set!    uconn tlsn)
    uconn))



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







>
>
>
>
>
>
>
>
>
>
>
>

















<
<
<
<
<
<
<
<
<
<






>







404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439










440
441
442
443
444
445
446
447
448
449
450
451
452
453
    (debug:print 0 *default-log-port* "INFO: starting server at " (common:human-time))
    (system (conc "nbfake " cmdln))
    (pop-directory)))

;;======================================================================
;; tcp connection stuff
;;======================================================================

;; 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 ttdat)
  (let* ((socket   (tt-socket  ttdat))
	 (handler  (tt-handler ttdat)))
    ((make-tcp-server socket handler)
     #t ;; 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)
       (setup-listener uconn (+ port 1))
       #f)
   (connect-listener uconn port)))











(define (connect-listener uconn port)
  ;; (tcp-listener-socket LISTENER)(socket-name so)
  ;; sockaddr-address, sockaddr-port, sockaddr->string
  (let* ((tlsn (tcp-listen port 1000 #f)) ;; (tcp-listen TCPPORT [BACKLOG [HOST]])
	 (addr  (tt:get-best-guess-address (get-host-name)))) ;; (get-my-best-address))) ;; (hostinfo-addresses (host-information (current-hostname)))
    (tt-port-set!      uconn port)
    (tt-host-set!      uconn addr)
    (tt-host-port-set! uconn (conc addr":"port))
    (tt-socket-set!    uconn tlsn)
    uconn))



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