Megatest

;; 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*)

                              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") 
         ;; (print "creating trigges from init") 
        (db:create-triggers db)    
     db)) ;; )

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

    (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))))))
	      (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))))))))

						(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"))
					     (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!)

	     (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))))
	#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)