Megatest

Check-in [ad08451b0a]
Login
Overview
Comment:Make server timeout configurable using existing settings
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.80
Files: files | file ages | folders
SHA1: ad08451b0a4d78fc5ae10dccef4e9814433e798e
User & Date: matt on 2023-03-14 08:06:44
Other Links: branch diff | manifest | tags
Context
2023-03-14
09:26
Fixed couple issues with setting server timeout. Reverted viewscreen to start in background as it didn't work properly without that. check-in: dda2fe1e9e user: matt tags: v1.80
08:06
Make server timeout configurable using existing settings check-in: ad08451b0a user: matt tags: v1.80
2023-03-13
08:37
Updated transport-mode templates check-in: 83e24c295f user: matt tags: v1.80
Changes

Modified megatest.scm from [c6a7ef8a82] to [f88c7a5d70].

942
943
944
945
946
947
948

949
950
951
952
953
954







955
956
957
958
959
960
961
942
943
944
945
946
947
948
949






950
951
952
953
954
955
956
957
958
959
960
961
962
963







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







    (let* (;; (run-id     (args:get-arg "-run-id"))
	   (dbfname    (args:get-arg "-db"))
	   (tl         (launch:setup))
	   (keys       (keys:config-get-fields *configdat*)))
      (case (rmt:transport-mode)
	((http)(http-transport:launch))
	((tcp)
	 (let* ((timeout    (server:expiration-timeout)))
	 (debug:print 0 *default-log-port* "INFO: Running using tcp method.")
	 (if dbfname
	     (tt:start-server tl #f dbfname api:tcp-dispatch-request-make-handler keys)
	     (begin
	       (debug:print 0 *default-log-port* "ERROR: transport mode is tcp - -db is required.")
	       (exit 1))))
	   (debug:print 0 *default-log-port* "INFO: Running using tcp method with server timeout of "timeout)
	   (tt-server-timeout-param timeout)
	   (if dbfname
	       (tt:start-server tl #f dbfname api:tcp-dispatch-request-make-handler keys)
	       (begin
		 (debug:print 0 *default-log-port* "ERROR: transport mode is tcp - -db is required.")
		 (exit 1)))))
	(else (debug:print 0 *default-log-port* "ERROR: rmt:transport-mode value not recognised "(rmt:transport-mode))))
      (set! *didsomething* #t)))

;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to
;; a specific Megatest area. Detail are being hashed out and this may change.
;;
(if (args:get-arg "-adjutant")

Modified tcp-transportmod.scm from [b2a28f339e] to [dde6c522b1].

100
101
102
103
104
105
106




107
108
109
110
111
112
113
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117







+
+
+
+







  (ro-mode      #f)
  (ro-mode-checked #f)
  (last-access  (current-seconds))
  (servinf-file #f)
  (last-serv-start 0)
  )

;; parameters
;;
(define tt-server-timeout-param (make-parameter 300))

;; make ttdat visible
(define *server-info* #f)

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

;; 1 ... or #f
449
450
451
452
453
454
455
456

457
458
459
460
461
462
463
453
454
455
456
457
458
459

460
461
462
463
464
465
466
467







-
+







	  (if (and (eq? (tt-state ttdat) 'running)
		   (> (- curr-secs last-update) 3)) ;; every 3-4 seconds update the db? maybe this should be refresh the inmem?
	      (begin
		(set! (file-modification-time (tt-servinf-file ttdat)) (current-seconds))
		((dbr:dbstruct-sync-proc dbstruct) last-update)
		(dbr:dbstruct-last-update-set! dbstruct curr-secs))))
	  
	(if (< (- (current-seconds) (tt-last-access ttdat)) 60)
	(if (< (- (current-seconds) (tt-last-access ttdat)) (tt-server-timeout-param))
	    (begin
	      (thread-sleep! 5)
	      (loop)))))
    (cleanup)
    (debug:print 0 *default-log-port* "INFO: Server timed out, exiting.")))