Megatest

(declare (uses pgdb))
(declare (uses mtmod))
(declare (uses megatestmod))

(use srfi-69)

(module tasksmod
	(
	 configf:write-alist
	 common:simple-unlock
	 common:simple-lock
	 tests:test-set-status!
	 common:get-launcher
	 tasks:kill-runner
	 tests:get-testconfig
	 tests:get-waitons

	 tests:get-test-path-from-environment
	 common:exit-on-version-changed
	 task:get-run-times
	 task:get-test-times
	 tasks:sync-to-postgres
	 tests:get-full-data
	 tasks:task-get-testpatt

	 )

(import scheme)
(cond-expand
 (chicken-4
  
  (import chicken
	  ports

              (debug:print 0 *default-log-port* " to switch versions you can run: \"megatest -cleanup-db\"")
              (exit 1)))))))
;;======================================================================
;;      (begin
;;	(debug:print 0 *default-log-port* "ERROR: cannot migrate version unless on homehost. Exiting.")
;;	(exit 1))))

;; (define (common:wait-for-homehost-load maxnormload msg)
;;   (let loop ((start-time (current-seconds))) ;; we saw some instances of this being called before *toppath* was set. This might be an early setup race. This delay should help but it is impossible to test...
;;     (if (not *toppath*)
;; 	(begin
;; 	  (debug:print 0 *default-log-port* "ERROR: common:wait-for-homehost-load called before *toppath* set.")
;; 	  (thread-sleep! 30)
;; 	  (if (< (- (current-seconds) start-time) 300)
;; 	      (loop start-time)))))
;;   (case (rmt:transport-mode)
;;     ((http)
;;      (let* ((hh-dat (if (rmt:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local.
;; 			#f
;; 			(server:choose-server *toppath* 'homehost)))
;;             (hh     (if hh-dat (car hh-dat) #f)))
;;        (common:wait-for-normalized-load maxnormload msg hh)))
;;     (else
;;      (common:wait-for-normalized-load maxnormload msg (get-host-name)))))
    

(define (configf:write-alist cdat fname)
  (if (not (common:faux-lock fname))
      (debug:print 0 *default-log-port* "INFO: Could not get lock on " fname))
  (let* ((dat  (configf:config->alist cdat))
         (res

         (lambda (missing-waiton)
            (debug:print-error 0 *default-log-port* "non-existent test \"" missing-waiton "\" is a waiton for tests " (hash-table-ref missing-waitons missing-waiton))
         )
         (hash-table-keys missing-waitons)
      )
))

;; make-vector-record tasks task id action owner state target name test item params creation_time execution_time 
(define (make-tasks:task)(make-vector 11))
(define (tasks:task-get-id               vec)    (vector-ref  vec 0))
(define (tasks:task-get-action           vec)    (vector-ref  vec 1))
(define (tasks:task-get-owner            vec)    (vector-ref  vec 2))
(define (tasks:task-get-state            vec)    (vector-ref  vec 3))
(define (tasks:task-get-target           vec)    (vector-ref  vec 4))
(define (tasks:task-get-name             vec)    (vector-ref  vec 5))
(define (tasks:task-get-testpatt         vec)    (vector-ref  vec 6))
(define (tasks:task-get-keylock          vec)    (vector-ref  vec 7))
(define (tasks:task-get-params           vec)    (vector-ref  vec 8))
(define (tasks:task-get-creation_time    vec)    (vector-ref  vec 9))
(define (tasks:task-get-execution_time   vec)    (vector-ref  vec 10))

(define (tasks:task-set-state!  vec val)(vector-set! vec 3 val))


;; make-vector-record tasks monitor id pid start_time last_update hostname username
(define (make-tasks:monitor)(make-vector 5))
(define (tasks:monitor-get-id            vec)    (vector-ref  vec 0))
(define (tasks:monitor-get-pid           vec)    (vector-ref  vec 1))
(define (tasks:monitor-get-start_time    vec)    (vector-ref  vec 2))
(define (tasks:monitor-get-last_update   vec)    (vector-ref  vec 3))
(define (tasks:monitor-get-hostname      vec)    (vector-ref  vec 4))
(define (tasks:monitor-get-username      vec)    (vector-ref  vec 5))

)