Megatest

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

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

(declare (unit rmt))
(declare (uses debugprint))
(declare (uses api))

(declare (uses commonmod))

(declare (uses dbfile))
(declare (uses dbmod))
(declare (uses tcp-transportmod))
(include "common_records.scm")
(declare (uses rmtmod))

;; used by http-transport
(import dbfile
	rmtmod
	commonmod

	debugprint
;; 	dbmemmod
	dbfile
	dbmod
	tcp-transportmod)

;;

     ((http)(make-remote))
     ((tcp) (tt:make-remote areapath))
     (else #f)))

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

(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id

;; 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
  (assert *toppath* "FATAL: rmt:send-receive called with *toppath* not set.")

  (if (not (eq? (rmt:transport-mode) 'nfs))
      (begin
	(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)))
	
	;; I'm turning this off, it may make sense to move it
	;; into http-transport-handler
	(if (and (> attemptnum 5) (= 0 (modulo attemptnum 15)))  
	    (begin
	      (debug:print 0 *default-log-port* "ERROR: can't connect to server, trying to start a server.")
	      (case (rmt:transport-mode)
		((http)
		 (server:run *toppath*)
		 (thread-sleep! 3))
		(else
		 (thread-sleep! 1) ;; for tcp the server is started by routines in tcp-transportmod. For nfs there is no server
		 ))))))
  
  ;; 1. check if server is started IFF cmd is a write OR if we are not on the homehost, store in runremote
  ;; 2. check the age of the connections. refresh the connection if it is older than timeout-20 seconds.
  ;; 3. do the query, if on homehost use local access
  ;;
  (let* ((start-time    (current-seconds)) ;; snapshot time so all use cases get same value
         (areapath      *toppath*);; TODO - resolve from dbstruct to be compatible with multiple areas
	 (runremote     (or area-dat
			    *runremote*))





         (attemptnum    (+ 1 attemptnum))






	 (readonly-mode (rmtmod:calc-ro-mode runremote *toppath*))
	 (testsuite     (common:get-testsuite-name))
	 (mtexe         (common:find-local-megatest)))

    (case (rmt:transport-mode)
      ((http)(http-transport-handler runremote cmd rid params attemptnum area-dat areapath readonly-mode))
      ((tcp) (tcp-transport-handler  runremote cmd rid params attemptnum area-dat areapath readonly-mode testsuite mtexe))
      ((nfs) (nfs-transport-handler  runremote cmd rid params attemptnum area-dat areapath readonly-mode testsuite mtexe))
      )))

(define (nfs-transport-handler  runremote cmd run-id params attemptnum area-dat areapath readonly-mode testsuite mtexe)
  (let* ((keys     (common:get-fields *configdat*))
	 (dbstruct (dbmod:nfs-get-dbstruct run-id keys (dbfile:db-init-proc) areapath tmpadj: "/dashboard")))
    (api:dispatch-request dbstruct cmd run-id params)))
	 
(define (tcp-transport-handler runremote cmd run-id params attemptnum area-dat areapath readonly-mode testsuite mtexe)
  (if (not runremote)
      (let* ((newremote  (make-and-init-remote areapath)))
	(set! *runremote* newremote)
	(set! runremote newremote)))
  (let* ((dbfname (conc (dbfile:run-id->dbnum run-id)".db"))) ;;(dbfile:run-id->path areapath run-id)))
    (tt:handler runremote cmd run-id params attemptnum area-dat areapath readonly-mode dbfname testsuite mtexe)))
	
(define (rmt:print-db-stats)
  (let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f"
    (debug:print 18 *default-log-port* "DB Stats\n========")
    (debug:print 18 *default-log-port* (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg"))
    (for-each (lambda (cmd)
		(let ((cmd-dat (hash-table-ref *db-stats* cmd)))
		  (debug:print 18 *default-log-port* (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0))))))
	      (sort (hash-table-keys *db-stats*)

		    (lambda (a b)











		      (> (vector-ref (hash-table-ref *db-stats* a) 0)







			 (vector-ref (hash-table-ref *db-stats* b) 0)))))))





(define (rmt:get-max-query-average run-id)
  (mutex-lock! *db-stats-mutex*)
  (let* ((runkey (conc "run-id=" run-id " "))
	 (cmds   (filter (lambda (x)
			   (substring-index runkey x))
			 (hash-table-keys *db-stats*)))
	 (res    (if (null? cmds)

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

	      #f))
	(begin
	  ;; (rmt:update-db-stats run-id cmd params duration)
	  ;; mark this run as dirty if this was a write, the watchdog is responsible for syncing it
	  (if qry-is-write
	      (let ((start-time (current-seconds)))
		(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))

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

;;======================================================================
;;  S E R V E R
;;======================================================================

(define (rmt:kill-server run-id)
  (rmt:send-receive 'kill-server run-id (list run-id)))

(define (rmt:start-server run-id)
  (rmt:send-receive 'start-server 0 (list run-id)))

;;======================================================================
;;  M I S C
;;======================================================================

(define (rmt:login run-id)
  (rmt:send-receive 'login run-id (list *toppath* megatest-version (client:get-signature))))

;; This login does no retries under the hood - it acts a bit like a ping.
;; Deprecated for nmsg-transport.
;;
;; (define (rmt:login-no-auto-client-setup runremote)
;;   (rmt:send-receive-no-auto-client-setup runremote 'login 0 (list *toppath* megatest-version (client:get-signature))))


;; given a hostname, return a pair of cpu load and update time representing latest intelligence from tests running on that host
(define (rmt:get-latest-host-load hostname)
  (rmt:send-receive 'get-latest-host-load 0 (list hostname)))

(define (rmt:sdb-qry qry val run-id)
  ;; add caching if qry is 'getid or 'getstr
  (rmt:send-receive 'sdb-qry run-id (list qry val)))

;; NOT COMPLETED
(define (rmt:runtests user run-id testpatt params)

(define (rmt:delete-run run-id)
  (rmt:send-receive 'delete-run #f (list run-id)))

(define (rmt:update-run-stats run-id stats)
  (rmt:send-receive 'update-run-stats #f (list run-id stats)))

(define (rmt:delete-old-deleted-test-records)
  (rmt:send-receive 'delete-old-deleted-test-records #f '()))

(define (rmt:get-runs runpatt count offset keypatts)
  (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts)))

(define (rmt:simple-get-runs runpatt count offset target last-update)
  (rmt:send-receive 'simple-get-runs #f (list runpatt count offset target last-update)))