Megatest

Check-in [e908cda9c3]
Login
Overview
Comment:Recovered couple lost edits. Switch default to -old for dispatcher
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.80-revolution-alt-dispatch
Files: files | file ages | folders
SHA1: e908cda9c3844ba7ee9e8397f568a5a2cd6eb99c
User & Date: mrwellan on 2024-01-29 12:43:59
Other Links: branch diff | manifest | tags
Context
2024-01-29
13:01
Merged in alt-dispatch changes check-in: 530b4ded14 user: mrwellan tags: v1.80-revolution
12:43
Recovered couple lost edits. Switch default to -old for dispatcher Leaf check-in: e908cda9c3 user: mrwellan tags: v1.80-revolution-alt-dispatch
2024-01-28
20:17
queue based handling WIP. Compiles and almost runs. check-in: 06c8fc61e9 user: matt tags: v1.80-revolution-alt-dispatch
Changes

Modified api.scm from [5ca8bfa389] to [755af5d3a9].

125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
		      (assert #f "FATAL: failed to deserialize indat "indat))))))
      ;; (set! *api-process-request-count* (- *api-process-request-count* 1))
      ;; (serialize payload)
     
      (api:unregister-thread (current-thread))
      result)))

(define api:tcp-dispatch-request-make-handler api:tcp-dispatch-request-make-handler-new)

(define *api-halt-writes* #f)

(define (api:dispatch-request dbstruct cmd run-id params)
  (if (not *no-sync-db*)
      (db:open-no-sync-db))
  (let* ((start-time (current-milliseconds)))







|







125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
		      (assert #f "FATAL: failed to deserialize indat "indat))))))
      ;; (set! *api-process-request-count* (- *api-process-request-count* 1))
      ;; (serialize payload)
     
      (api:unregister-thread (current-thread))
      result)))

(define api:tcp-dispatch-request-make-handler api:tcp-dispatch-request-make-handler-old) ;; choose -old or -new

(define *api-halt-writes* #f)

(define (api:dispatch-request dbstruct cmd run-id params)
  (if (not *no-sync-db*)
      (db:open-no-sync-db))
  (let* ((start-time (current-milliseconds)))

Modified megatest.scm from [0b10f3d522] to [f57dc1364c].

975
976
977
978
979
980
981

982
983
984
985
986
987
988
	   (tl         (launch:setup))
	   (keys       (keys:config-get-fields *configdat*)))
      (case (rmt:transport-mode)
	((tcp)
	 (let* ((timeout    (server:expiration-timeout)))
	   (debug:print 0 *default-log-port* "INFO: megatest -server starting on " (get-host-name) " for " dbfname " using tcp method with timeout of "timeout)
	   (tt-server-timeout-param timeout)

	   (thread-start! (make-thread api:print-db-stats "print-db-stats"))
	   (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))))







>







975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
	   (tl         (launch:setup))
	   (keys       (keys:config-get-fields *configdat*)))
      (case (rmt:transport-mode)
	((tcp)
	 (let* ((timeout    (server:expiration-timeout)))
	   (debug:print 0 *default-log-port* "INFO: megatest -server starting on " (get-host-name) " for " dbfname " using tcp method with timeout of "timeout)
	   (tt-server-timeout-param timeout)
	   (api:queue-processor)
	   (thread-start! (make-thread api:print-db-stats "print-db-stats"))
	   (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))))

Modified rmtmod.scm from [883a743d2f] to [c803418b6e].

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
;; Maintenance
;;======================================================================


(define (rmt:get-toplevels-and-incompletes run-id running-deadtime remotehoststart-deadtime)
  (rmtmod:send-receive 'get-toplevels-and-incompletes run-id (list run-id running-deadtime remotehoststart-deadtime)))





(define (rmt:get-status-from-final-status-file run-dir)
  (let ((infile (conc run-dir "/.final-status")))
    ;; first verify we are able to write the output file
    (if (not (file-read-access? infile))
        (begin 
	  (debug:print 2 *default-log-port* "ERROR: cannot read " infile)
          (debug:print 2 *default-log-port* "ERROR: run-dir is " run-dir)
          #f
          )
	(let ((res (with-input-from-file infile read-lines)))
	  (if (null? res)
	      #f

	      (string-split (car res)))))))
  
;;  select end_time-now from
;;      (select testname,item_path,event_time+run_duration as
;;                          end_time,strftime('%s','now') as now from tests where state in
;;      ('RUNNING','REMOTEHOSTSTART','LAUNCHED'));
;;
;; NOT EASY TO MIGRATE TO db{file,mod}







>
>
>
>


|









>
|







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
;; Maintenance
;;======================================================================


(define (rmt:get-toplevels-and-incompletes run-id running-deadtime remotehoststart-deadtime)
  (rmtmod:send-receive 'get-toplevels-and-incompletes run-id (list run-id running-deadtime remotehoststart-deadtime)))

;; .final-status file is two lines:
;; "state"
;; "status"
;;
(define (rmt:get-status-from-final-status-file run-dir)
  (let ((infile (conc run-dir "/.final-status")))
    ;; first verify we are able to read the output file
    (if (not (file-read-access? infile))
        (begin 
	  (debug:print 2 *default-log-port* "ERROR: cannot read " infile)
          (debug:print 2 *default-log-port* "ERROR: run-dir is " run-dir)
          #f
          )
	(let ((res (with-input-from-file infile read-lines)))
	  (if (null? res)
	      #f
	      res))))) ;; (string-split (car res))))))) <== I would have preferred a single line STATE STATUS without "'s
	      ;; (string-split (car res))))))) ;; DUNNO WHICH IS CORRECT
  
;;  select end_time-now from
;;      (select testname,item_path,event_time+run_duration as
;;                          end_time,strftime('%s','now') as now from tests where state in
;;      ('RUNNING','REMOTEHOSTSTART','LAUNCHED'));
;;
;; NOT EASY TO MIGRATE TO db{file,mod}

Modified tests.scm from [776a2ca8e7] to [af6a335a09].

1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445


1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
(define (tests:save-final-status run-id test-id)
  (let* ((test-dat  (rmt:get-test-info-by-id run-id test-id))
	 (out-dir   (db:test-get-rundir test-dat))
	 (status-file  (conc out-dir "/.final-status"))
   )
    ;; first verify we are able to write the output file
    (if (not (file-write-access? out-dir))
	    (debug:print 0 *default-log-port* "ERROR: cannot write .final-status to " out-dir)
	    (let* 
         ((outp      (open-output-file status-file))
	       (status    (db:test-get-status   test-dat))
         (state     (db:test-get-state    test-dat)))
        (fprintf outp "~S\n" state) 


        (fprintf outp "~S\n" status) 
        (close-output-port outp)))))


;; summarize test in to a file test-summary.html in the test directory
;;
(define (tests:summarize-test run-id test-id)
  (let* ((test-dat  (rmt:get-test-info-by-id run-id test-id))
	 (out-dir   (db:test-get-rundir test-dat))
	 (out-file  (conc out-dir "/test-summary.html")))







|
<
|

|
|
>
>
|
|
<







1433
1434
1435
1436
1437
1438
1439
1440

1441
1442
1443
1444
1445
1446
1447
1448

1449
1450
1451
1452
1453
1454
1455
(define (tests:save-final-status run-id test-id)
  (let* ((test-dat  (rmt:get-test-info-by-id run-id test-id))
	 (out-dir   (db:test-get-rundir test-dat))
	 (status-file  (conc out-dir "/.final-status"))
   )
    ;; first verify we are able to write the output file
    (if (not (file-write-access? out-dir))
	(debug:print 0 *default-log-port* "ERROR: cannot write .final-status to " out-dir)

	(let* ((outp      (open-output-file status-file))
	       (status    (db:test-get-status   test-dat))
	       (state     (db:test-get-state    test-dat)))
	  (with-output-to-port outp
	    (lambda ()
	      (print state) ;; printf was putting in ", not sure why but that was a hassle in other contexts
	      (print status)))
	  (close-output-port outp)))))


;; summarize test in to a file test-summary.html in the test directory
;;
(define (tests:summarize-test run-id test-id)
  (let* ((test-dat  (rmt:get-test-info-by-id run-id test-id))
	 (out-dir   (db:test-get-rundir test-dat))
	 (out-file  (conc out-dir "/test-summary.html")))