Megatest

;;======================================================================

(use format typed-records) ;; RADT => purpose of json format??

(declare (unit rmt))
(declare (uses api))
(declare (uses http-transport))
(declare (uses dbfile))
(include "common_records.scm")
;; (declare (uses rmtmod))

(import dbfile) ;; rmtmod)

;;
;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!
;;

;; generate entries for ~/.megatestrc with the following
;;

;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname))
;;
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected

  #;(common:telemetry-log (conc "rmt:"(->string cmd))
                        payload: `((rid . ,rid)
                                   (params . ,params)))

  (if (> attemptnum 2)
      (debug:print 0 *default-log-port* "INFO: attemptnum in rmt:send-receive is " attemptnum))
    
  (cond
   ((> attemptnum 2) (thread-sleep! 0.05))
   ((> attemptnum 10) (thread-sleep! 0.5))
   ((> attemptnum 20) (thread-sleep! 1)))

    ;; ensure we have a homehost record
    (if (not (pair? (remote-hh-dat runremote)))  ;; not on homehost
	(thread-sleep! 0.1) ;; since we shouldn't get here, delay a little
	(remote-hh-dat-set! runremote (common:get-homehost)))
    
    ;;(print "BB> readonly-mode is "readonly-mode" dbfile is "dbfile)
    (cond
     #;((> (- (current-seconds)(remote-connect-time runremote)) 180) ;; reconnect to server every 180 seconds
      (debug:print 0 *default-log-port* "Forcing reconnect to server(s) due to 180 second timeout.")
      (set! *runremote* #f)
      ;; BUG: close-connections should go here?
      (mutex-unlock! *rmt-mutex*)
      (rmt:send-receive cmd rid params attemptnum: 1 area-dat: area-dat))
     
     ;;DOT EXIT;
     ;;DOT MUTEXLOCK -> EXIT [label="> 15 attempts"]; {rank=same "case 1" "EXIT" }
     ;; give up if more than 150 attempts
     ((> attemptnum 150)
      (debug:print 0 *default-log-port* "ERROR: 150 tries to start/connect to server. Giving up.")
      (exit 1))

				 (cons newmax-cmd currmax)
				 (cons 'none 0))
			     (loop (car tal)(cdr tal) newmax-cmd currmax)))))))
    (mutex-unlock! *db-stats-mutex*)
    res))

(define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5))
  (let* ((qry-is-write    (not (member cmd api:read-only-queries)))
	 (db-file-path    (db:dbfile-path)) ;;  0))
	 (dbstructs-local (db:setup #t))  ;; make-dbr:dbstruct path:  dbdir local: #t)))
	 (read-only       (not (file-write-access? db-file-path)))
	 (start           (current-milliseconds))
	 (resdat          (if (not (and read-only qry-is-write))
			      (let ((v (api:execute-requests dbstructs-local (vector (symbol->string cmd) params))))
			;;	(handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong..
			;;	 exn               ;;  This is an attempt to detect that situation and recover gracefully
			;;	 (begin
			;;	   (debug:print 0 *default-log-port* "ERROR: bad data from server " v " message: "  ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
			;;	   (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy
				 (if (and (vector? v)
					  (> (vector-length v) 1))
				     (let ((newvec (vector (vector-ref v 0)(vector-ref v 1))))
				       newvec)           ;; by copying the vector while inside the error handler we should force the detection of a corrupted record
				     (vector #t '()))) ;; )  ;; we could also check that the returned types are valid
			      (vector #t '())))
	 (success        (vector-ref resdat 0))
	 (res            (vector-ref resdat 1))
	 (duration       (- (current-milliseconds) start)))
    (if (and read-only qry-is-write)
        (debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd))
    (if (not success)
	(if (> remretries 0)

		(mutex-lock! *db-multi-sync-mutex*)
/		(set! *db-last-access* start-time)  ;; THIS IS PROBABLY USELESS? (we are on a client)
                (mutex-unlock! *db-multi-sync-mutex*)))))
    res))

(define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params)
  (let* ((run-id   (if run-id run-id 0))
	 (res  	   ;; (handle-exceptions
		   ;;     exn
		   ;;   (begin
		   ;;     (print "transport failed. exn=" exn)
		   ;;     #f)
		     (http-transport:client-api-send-receive run-id connection-info cmd params))) ;; )
    (if (and res (vector-ref res 0))
	(vector-ref res 1) ;;; YES!! THIS IS CORRECT!! CHANGE IT HERE, THEN CHANGE rmt:send-receive ALSO!!!
	#f)))

;;======================================================================
;;
;; A C T U A L   A P I   C A L L S  

(define (rmt:delete-steps-for-test! run-id test-id)
  (rmt:send-receive 'delete-steps-for-test! run-id (list run-id test-id)))

(define (rmt:get-steps-for-test run-id test-id)
  (rmt:send-receive 'get-steps-for-test run-id (list run-id test-id)))

(define (rmt:get-steps-info-by-id run-id test-step-id)
  (rmt:send-receive 'get-steps-info-by-id #f (list run-id test-step-id)))

;;======================================================================
;;  T E S T   D A T A 
;;======================================================================

(define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) 
  (rmt:send-receive 'read-test-data run-id (list run-id test-id categorypatt)))

(define (rmt:read-test-data-varpatt run-id test-id categorypatt varpatt #!key (work-area #f)) 
  (rmt:send-receive 'read-test-data-varpatt run-id (list run-id test-id categorypatt varpatt)))

(define (rmt:get-data-info-by-id run-id test-data-id)
   (rmt:send-receive 'get-data-info-by-id #f (list run-id test-data-id)))

(define (rmt:testmeta-add-record testname)
  (rmt:send-receive 'testmeta-add-record #f (list testname)))

(define (rmt:testmeta-get-record testname)
  (rmt:send-receive 'testmeta-get-record #f (list testname)))

  (rmt:send-receive 'test-get-archive-block-info #f (list archive-block-id)))


(define (rmtmod:calc-ro-mode runremote *toppath*)
  (if (and runremote
	   (remote-ro-mode-checked runremote))
      (remote-ro-mode runremote)
      (let* ((mtcfgfile  (conc *toppath* "/megatest.config"))
	     (ro-mode (not (file-write-access? mtcfgfile)))) ;; TODO: use dbstruct or runremote to figure this out in future
	(if runremote
	    (begin
	      (remote-ro-mode-set! runremote ro-mode)
	      (remote-ro-mode-checked-set! runremote #t)
	      ro-mode)
	    ro-mode))))