Megatest

rmtmod.scm at [99551309fa]
Login

File rmtmod.scm artifact dc8573987a part of check-in 99551309fa


;;======================================================================
;; Copyright 2019, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

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

(declare (unit rmtmod))
(declare (uses commonmod))

(module rmtmod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
(import commonmod)
(use (prefix ulex ulex:))

(define (member:print msg x lst)
  (print "member-" msg ": x=" x " lst=" lst)
  (member x lst))

;; Hack to make these functions visible to the refactored code, goal is to eliminate these over time.
(define (rmt:send-receive . params) #f)
(define (http-transport:close-connections . params) #f)
;; from remote defstruct in common.scm
(define (remote-conndat-set! . params) #f)
(define (remote-server-url-set! . params) #f)
(define (remote-ro-mode . params) #f)
(define (remote-ro-mode-set! . params) #f)
(define (remote-ro-mode-checked-set! . params) #f)
(define (remote-ro-mode-checked . params) #f)
(define (debug:print . params) #f)
(define (debug:print-info . params) #f)
(define (debug:print-error . params) #f)
(define (db:dbfile-path . params) #f)
(define (db:setup . params) #f)
(define (api:execute-requests . params) #f)

(define (set-functions send-receive        rsus
		       close-connections   rcs
		       dbgp                dbgpinfo
		       dbgperr
		       ro-mode             ro-mode-set
		       ro-mode-checked-set ro-mode-checked

		       dbfile-path         dbsetup
		       exec-req            read-only-queries
		       ) 
  (set! rmt:send-receive            send-receive)
  (set! remote-server-url-set!           rsus)
  (set! http-transport:close-connections close-connections)
  (set! remote-conndat-set!              rcs)
  ;; print stuff
  (set! debug:print                      dbgp)
  (set! debug:print-info                 dbgpinfo)
  (set! debug:print-error                dbgperr)
  ;;
  (set! remote-ro-mode                   ro-mode)
  (set! remote-ro-mode-set!              ro-mode-set)
  (set! remote-ro-mode-checked-set!      ro-mode-checked-set)
  (set! remote-ro-mode-checked           ro-mode-checked)
  ;; db stuff for local db access
  (set! db:dbfile-path                   dbfile-path)
  (set! db:setup                         dbsetup)
  (set! apt:execute-requests             exec-req)
  )

(define (rmt:open-qry-close-locally log-port multi-sync-mutex cmd run-id params #!key (ro-queries '())(remretries 5))
  (let* ((qry-is-write   (not (member:print "#1" cmd ro-queries)))
	 (db-file-path   (db:dbfile-path)) ;;  0))
	 (dbstruct-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 dbstruct-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 log-port "ERROR: bad data from server " v " message: "  ((condition-property-accessor 'exn 'message) 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 log-port "ERROR: attempt to write to read-only database ignored. cmd=" cmd))
    (if (not success)
	(if (> remretries 0)
	    (begin
	      (debug:print-error 0 log-port "local query failed. Trying again.")
	      (thread-sleep! (/ (random 5000) 1000)) ;; some random delay 
	      (rmt:open-qry-close-locally log-port multi-sync-mutex cmd run-id params ro-queries: ro-queries remretries: (- remretries 1)))
	    (begin
	      (debug:print-error 0 log-port "too many retries in rmt:open-qry-close-locally, giving up")
	      #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! multi-sync-mutex)
		(set! *db-last-access* start-time)  ;; THIS IS PROBABLY USELESS? (we are on a client)
                (mutex-unlock! multi-sync-mutex)))))
    res))



(define (rmtmod:calc-ro-mode runremote toppath)
  (if (and runremote
	   (remote-ro-mode-checked runremote))
      (remote-ro-mode runremote)
      (let* ((dbfile  (conc toppath "/megatest.db"))
	     (ro-mode (not (file-write-access? dbfile)))) ;; 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))))

(define (extras-readonly-mode rmt-mutex log-port cmd params)
  ;;(mutex-unlock! rmt-mutex)
  (debug:print-info 12 log-port "rmt:send-receive, case 3")
  (debug:print 0 log-port "WARNING: write transaction requested on a readonly area.  cmd="cmd" params="params)
  #f)

(define (extras-transport-failed *default-log-port* *rmt-mutex* attemptnum runremote cmd rid params)
  (debug:print 0 *default-log-port* "WARNING: communication failed. Trying again, try num: " attemptnum)
  ;;(mutex-lock! *rmt-mutex*)
  (remote-conndat-set!    runremote #f)
  (http-transport:close-connections area-dat: runremote)
  (remote-server-url-set! runremote #f)
  ;;(mutex-unlock! *rmt-mutex*)
  (debug:print-info 12 *default-log-port* "rmt:send-receive, case  9.1")
  (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))
  
(define (extras-transport-succeded *default-log-port* *rmt-mutex* attemptnum runremote res params rid cmd)
  (if (and (vector? res)
	   (eq? (vector-length res) 2)
	   (eq? (vector-ref res 1) 'overloaded)) ;; since we are
						 ;; looking at the
						 ;; data to carry the
						 ;; error we'll use a
						 ;; fairly obtuse
						 ;; combo to minimise
						 ;; the chances of
						 ;; some sort of
						 ;; collision.  this
						 ;; is the case where
						 ;; the returned data
						 ;; is bad or the
						 ;; server is
						 ;; overloaded and we
						 ;; want to ease off
						 ;; the queries
      (let ((wait-delay (+ attemptnum (* attemptnum 10))))
	(debug:print 0 *default-log-port* "WARNING: server is overloaded. Delaying " wait-delay " seconds and trying call again.")
	;;(mutex-lock! *rmt-mutex*)
	(http-transport:close-connections area-dat: runremote)
	(set! *runremote* #f) ;; force starting over
	;;(mutex-unlock! *rmt-mutex*)
	(thread-sleep! wait-delay)
	(rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))
      res)) ;; All good, return res

;;======================================================================
;; ulex and steps stuff
;;======================================================================

(define (rmtmod:setup-ulex toppath)
  (ulex:make-area
   dbdir:   (conc toppath "/ulexdb")
   pktsdir: (conc toppath "/pkts") 
   ))



(define (rmtmod:send-receive-ulex ulex:conn cmd rid params attemptnum area-dat)
  #f)

(use trace)(trace-call-sites #t)
(trace member rmtmod:calc-ro-mode rmt:open-qry-close-locally member:print)

)