Megatest

Check-in [74a5cd0abb]
Login
Overview
Comment:Merged in latest From: 14db3c2571c703c23f8b627c1d3ca06d22870c57 User: matt
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.65-diet2-cm1
Files: files | file ages | folders
SHA1: 74a5cd0abb629a3952a110202a63528a171c7bfa
User & Date: matt on 2021-02-26 07:53:35
Other Links: branch diff | manifest | tags
Context
2021-02-26
07:53
deal with empty response From: 82ee02c9c1b7012786a26a103cd6d6380b61352a User: matt Leaf check-in: b850770938 user: matt tags: v1.65-diet2-cm1 (unpublished)
07:53
Merged in latest From: 14db3c2571c703c23f8b627c1d3ca06d22870c57 User: matt check-in: 74a5cd0abb user: matt tags: v1.65-diet2-cm1 (unpublished)
07:47
use old rollup technique From: 195f4a1733d50ea9e6e755336c8d51dd761e478d User: matt check-in: 5cd6156bc0 user: matt tags: v1.65-diet2-cm1 (unpublished)
Changes

Modified api.scm from [7029eb2f68] to [913dee30b8].

376
377
378
379
380
381
382

383
384
385
386
387
388
389
;; http-server  send-response
;;                 api:process-request
;;                    db:*
;;
;; NB// Runs on the server as part of the server loop
;;
(define (api:process-request dbstruct $) ;; the $ is the request vars proc

  (debug:print 4 *default-log-port* "server-id:"  *server-id*)
  (let* ((cmd     ($ 'cmd))
	 (paramsj ($ 'params))
         (key     ($ 'key))   
	 (params  (db:string->obj paramsj transport: 'http))) ;; incoming data from the POST (or is it a GET?)
    (debug:print 4 *default-log-port* "cmd:" cmd " with params " params "key " key)
    (if (equal? key *server-id*)







>







376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
;; http-server  send-response
;;                 api:process-request
;;                    db:*
;;
;; NB// Runs on the server as part of the server loop
;;
(define (api:process-request dbstruct $) ;; the $ is the request vars proc
  (debug:print 4 *default-log-port* "server-id:"  *server-id*)
  (debug:print 4 *default-log-port* "server-id:"  *server-id*)
  (let* ((cmd     ($ 'cmd))
	 (paramsj ($ 'params))
         (key     ($ 'key))   
	 (params  (db:string->obj paramsj transport: 'http))) ;; incoming data from the POST (or is it a GET?)
    (debug:print 4 *default-log-port* "cmd:" cmd " with params " params "key " key)
    (if (equal? key *server-id*)

Modified db.scm from [39934e4086] to [2f9964a2a3].

1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
                              id           INTEGER PRIMARY KEY,
                              test_id      INTEGER,
                              state        TEXT DEFAULT 'new',
                              status       TEXT DEFAULT 'n/a',
                              archive_type TEXT DEFAULT 'bup',
                              du           INTEGER,
                              archive_path TEXT);")))
         (print "creating triggers from init") 
        (db:create-triggers db)    
     db)) ;; )

;;======================================================================
;; A R C H I V E S
;;======================================================================








|







1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
                              id           INTEGER PRIMARY KEY,
                              test_id      INTEGER,
                              state        TEXT DEFAULT 'new',
                              status       TEXT DEFAULT 'n/a',
                              archive_type TEXT DEFAULT 'bup',
                              du           INTEGER,
                              archive_path TEXT);")))
         ;; (print "creating trigges from init") 
        (db:create-triggers db)    
     db)) ;; )

;;======================================================================
;; A R C H I V E S
;;======================================================================

4004
4005
4006
4007
4008
4009
4010



4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039

    (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item
	(begin
	  ;; is there a rollup lock? If not, take it
	  (sqlite3:with-transaction
	   no-sync-db
	   (lambda ()



	     (let* ((rollup-lock-time (db:no-sync-get/default no-sync-db rollup-lock-key #f))
		    (waiting-lock-time (db:no-sync-get/default no-sync-db waiting-lock-key #f)))
	       (if rollup-lock-time ;; someone is doing a rollup
		   (if (not waiting-lock-time) ;; no one is waiting
		       (begin
			 (set! wait-flag #t)
			 (set! rollup-flag #t)
			 (db:no-sync-set no-sync-db waiting-lock-key (current-seconds)))) ;; we are going to wait
		   (begin
		     (set! rollup-flag #t)
		     (db:no-sync-set no-sync-db rollup-lock-key (current-seconds)))))))
	  (if wait-flag
	      (let loop ((count 100))
		(thread-sleep! 2)
		(if (and (not (db:no-sync-get/default no-sync-db waiting-lock-key #f))
			 (> count 0))
		    (loop (+ count 1))
		    (sqlite3:with-transaction
		     no-sync-db
		     (lambda ()
		       (db:no-sync-set no-sync-db rollup-lock-key (current-seconds))
		       (db:no-sync-del! no-sync-db waiting-lock-key))))))
	  ;; now the rollup
	  (if rollup-flag ;; put this into a thread
	      (thread-start! (make-thread
			      (lambda ()
				(db:roll-up-test-state-status dbstruct run-id test-name state status)
				(db:no-sync-del! no-sync-db rollup-flag))
			      (conc "thread for run-id: " run-id " test-name: " test-name))))))))







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







4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042

    (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item
	(begin
	  ;; is there a rollup lock? If not, take it
	  (sqlite3:with-transaction
	   no-sync-db
	   (lambda ()
	     (handle-exceptions
	      exn
	      (debug:print 0 *default-log-port* "EXCEPTION: exn="exn)
	      (let* ((rollup-lock-time (db:no-sync-get/default no-sync-db rollup-lock-key #f))
		     (waiting-lock-time (db:no-sync-get/default no-sync-db waiting-lock-key #f)))
		(if rollup-lock-time ;; someone is doing a rollup
		    (if (not waiting-lock-time) ;; no one is waiting
			(begin
			  (set! wait-flag #t)
			  (set! rollup-flag #t)
			  (db:no-sync-set no-sync-db waiting-lock-key (current-seconds)))) ;; we are going to wait
		    (begin
		      (set! rollup-flag #t)
		      (db:no-sync-set no-sync-db rollup-lock-key (current-seconds)))))))
	   (if wait-flag
	       (let loop ((count 100))
		 (thread-sleep! 2)
		 (if (and (not (db:no-sync-get/default no-sync-db waiting-lock-key #f))
			  (> count 0))
		     (loop (+ count 1))
		     (sqlite3:with-transaction
		      no-sync-db
		      (lambda ()
			(db:no-sync-set no-sync-db rollup-lock-key (current-seconds))
			(db:no-sync-del! no-sync-db waiting-lock-key)))))))
	  ;; now the rollup
	  (if rollup-flag ;; put this into a thread
	      (thread-start! (make-thread
			      (lambda ()
				(db:roll-up-test-state-status dbstruct run-id test-name state status)
				(db:no-sync-del! no-sync-db rollup-flag))
			      (conc "thread for run-id: " run-id " test-name: " test-name))))))))

Modified http-transport.scm from [2202b22e9f] to [26871a62d6].

290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
						(mutex-unlock! *http-mutex*)
					     ;;; (signal (make-composite-condition
					     ;;;          (make-property-condition 'commfail 'message "failed to connect to server")))
					     ;;; "communications failed"
						(db:obj->string #f))
					    (with-input-from-request ;; was dat
					     fullurl 
					     (list (cons 'key (or server-id   "thekey"))
						   (cons 'cmd cmd)
						   (cons 'params sparams))
					     read-string))
					  transport: 'http)
                                         0)) ;; added this speculatively
			      ;; Shouldn't this be a call to the managed call-all-connections stuff above?
			      (close-all-connections!)







|







290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
						(mutex-unlock! *http-mutex*)
					     ;;; (signal (make-composite-condition
					     ;;;          (make-property-condition 'commfail 'message "failed to connect to server")))
					     ;;; "communications failed"
						(db:obj->string #f))
					    (with-input-from-request ;; was dat
					     fullurl 
					     (list (cons 'key (or server-id "thekey"))
						   (cons 'cmd cmd)
						   (cons 'params sparams))
					     read-string))
					  transport: 'http)
                                         0)) ;; added this speculatively
			      ;; Shouldn't this be a call to the managed call-all-connections stuff above?
			      (close-all-connections!)

Modified server.scm from [5b645d5dff] to [94a46368fe].

334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
	     (not (null? srvrs)))
	(let* ((len (length srvrs))
	       (idx (random len)))
	  (list-ref srvrs idx))
	#f)))

(define (server:record->id servr)
  (handle-exceptions
   exn
   (begin 
     (debug:print-info 0 *default-log-port*  "Unable to get server id from " servr ", exn=" exn)     
   #f)
  (match-let (((mod-time host port start-time server-id pid)
	       servr))
    (if server-id
	server-id
	#f))))

(define (server:record->url servr)
  (handle-exceptions
   exn
   (begin 
     (debug:print-info 0 *default-log-port*  "Unable to get server url from " servr ", exn=" exn)     
   #f)







<
<
<
<
<




|







334
335
336
337
338
339
340





341
342
343
344
345
346
347
348
349
350
351
352
	     (not (null? srvrs)))
	(let* ((len (length srvrs))
	       (idx (random len)))
	  (list-ref srvrs idx))
	#f)))

(define (server:record->id servr)





  (match-let (((mod-time host port start-time server-id pid)
	       servr))
    (if server-id
	server-id
	#f)))

(define (server:record->url servr)
  (handle-exceptions
   exn
   (begin 
     (debug:print-info 0 *default-log-port*  "Unable to get server url from " servr ", exn=" exn)     
   #f)