Megatest

Check-in [844a9d0924]
Login
Overview
Comment:wip
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v2.0001
Files: files | file ages | folders
SHA1: 844a9d0924252f52b5a9065739c7970ec3aa4661
User & Date: matt on 2022-01-02 20:49:02
Other Links: branch diff | manifest | tags
Context
2022-01-03
09:34
wip check-in: db564d80d9 user: matt tags: v2.0001
2022-01-02
20:49
wip check-in: 844a9d0924 user: matt tags: v2.0001
18:44
wip check-in: 9579cb5f06 user: matt tags: v2.0001
Changes

Modified apimod.scm from [d0ed8f0a49] to [dab49c5a9c].

372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
    ((have-incompletes?)            (apply db:have-incompletes? dbstruct params))
    ((login)                        (apply db:login dbstruct params))
    ((general-call)                 (let ((stmtname   (car params))
					  (run-id     (cadr params))
					  (realparams (cddr params)))
				      (db:general-call dbstruct stmtname run-id realparams)))
    ((sdb-qry)                      (apply sdb:qry params))
    ((ping)                         (current-process-id))
    ((get-changed-record-ids)       (apply db:get-changed-record-ids dbstruct params))
    ((get-run-record-ids) 	   (apply db:get-run-record-ids dbstruct params))	
    ;; TESTMETA
    ((testmeta-get-record)       (apply db:testmeta-get-record dbstruct params))

    ;; TASKS 
    ((find-task-queue-records)   (apply tasks:find-task-queue-records dbstruct params))







|







372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
    ((have-incompletes?)            (apply db:have-incompletes? dbstruct params))
    ((login)                        (apply db:login dbstruct params))
    ((general-call)                 (let ((stmtname   (car params))
					  (run-id     (cadr params))
					  (realparams (cddr params)))
				      (db:general-call dbstruct stmtname run-id realparams)))
    ((sdb-qry)                      (apply sdb:qry params))
    ((ping)                         `(#t ,(current-process-id) (cadr params))) ;; (current-process-id))
    ((get-changed-record-ids)       (apply db:get-changed-record-ids dbstruct params))
    ((get-run-record-ids) 	   (apply db:get-run-record-ids dbstruct params))	
    ;; TESTMETA
    ((testmeta-get-record)       (apply db:testmeta-get-record dbstruct params))

    ;; TASKS 
    ((find-task-queue-records)   (apply tasks:find-task-queue-records dbstruct params))

Modified rmtmod.scm from [fb260a632c] to [622fc59774].

157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179

180
181
182
183
184
185
186
187
;;  S U P P O R T   F U N C T I O N S
;;======================================================================

;; set up the api proc, seems like there should be a better place for this?
;;
;; IS THIS NEEDED ANYMORE? TODO - REMOVE IF POSSIBLE
;;
(define api-proc (make-parameter conc))
(api-proc api:execute-requests)

;; do we have a connection to apath dbname and
;; is it not expired? then return it
;;
;; else setup a connection
;;
;; if that fails, return '(#f "some reason") ;; NB// convert to raising an exception
;;
(define (rmt:get-conn remdat apath dbname)
  (let* ((fullname (db:dbname->path apath dbname))
	 (conn     (hash-table-ref/default (servdat-conns remdat) fullname #f)))
    (if (and conn
	     (< (current-seconds) (conndat-expires conn)))
	conn

	#f)))

(define (rmt:find-main-server uconn apath dbname)
  (let* ((pktsdir     (get-pkts-dir apath))
	 (all-srvpkts (get-all-server-pkts pktsdir *srvpktspec*))
	 ;; (dbpath      (conc apath "/" dbname))
	 (viable-srvs (get-viable-servers all-srvpkts dbname)))
    (get-the-server uconn apath viable-srvs)))







|
|














>
|







157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
;;  S U P P O R T   F U N C T I O N S
;;======================================================================

;; set up the api proc, seems like there should be a better place for this?
;;
;; IS THIS NEEDED ANYMORE? TODO - REMOVE IF POSSIBLE
;;
;; (define api-proc (make-parameter conc))
;; (api-proc api:execute-requests)

;; do we have a connection to apath dbname and
;; is it not expired? then return it
;;
;; else setup a connection
;;
;; if that fails, return '(#f "some reason") ;; NB// convert to raising an exception
;;
(define (rmt:get-conn remdat apath dbname)
  (let* ((fullname (db:dbname->path apath dbname))
	 (conn     (hash-table-ref/default (servdat-conns remdat) fullname #f)))
    (if (and conn
	     (< (current-seconds) (conndat-expires conn)))
	conn
	#f ;; TODO - convert this to a refresh for the given db? (server could have moved)
	)))

(define (rmt:find-main-server uconn apath dbname)
  (let* ((pktsdir     (get-pkts-dir apath))
	 (all-srvpkts (get-all-server-pkts pktsdir *srvpktspec*))
	 ;; (dbpath      (conc apath "/" dbname))
	 (viable-srvs (get-viable-servers all-srvpkts dbname)))
    (get-the-server uconn apath viable-srvs)))
229
230
231
232
233
234
235
236

237
238
239
240
241
242
243
	     (the-srv        (rmt:find-main-server myconn apath dbname))
	     (start-main-srv (lambda () ;; call IF there is no the-srv found
			       (mutex-lock! *connstart-mutex*)
			       (if (> (- (current-seconds) *last-main-start*) 5) ;; at least four seconds since last attempt to start main server
				   (begin
				     (api:run-server-process apath dbname)
				     (set! *last-main-start* (current-seconds))
				     (thread-sleep! 1)))

			       (mutex-unlock! *connstart-mutex*)
			       (rmt:open-main-connection remdat apath) ;; TODO: Add limit to number of tries
			       )))
	(if (not the-srv) ;; have server, try connecting to it
	    (start-main-srv)
	    (let* ((srv-addr (server-address the-srv)) ;; need serv
		   (ipaddr   (alist-ref 'ipaddr  the-srv))







|
>







230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
	     (the-srv        (rmt:find-main-server myconn apath dbname))
	     (start-main-srv (lambda () ;; call IF there is no the-srv found
			       (mutex-lock! *connstart-mutex*)
			       (if (> (- (current-seconds) *last-main-start*) 5) ;; at least four seconds since last attempt to start main server
				   (begin
				     (api:run-server-process apath dbname)
				     (set! *last-main-start* (current-seconds))
				     (thread-sleep! 1))
				   (thread-sleep! 0.25))
			       (mutex-unlock! *connstart-mutex*)
			       (rmt:open-main-connection remdat apath) ;; TODO: Add limit to number of tries
			       )))
	(if (not the-srv) ;; have server, try connecting to it
	    (start-main-srv)
	    (let* ((srv-addr (server-address the-srv)) ;; need serv
		   (ipaddr   (alist-ref 'ipaddr  the-srv))
352
353
354
355
356
357
358
359
360
361
362
363
364

365
366
367
368
369
370
371
372
373
374
375
	  (if rid (rmt:general-open-connection sinfo apath dbname))
	  (rmt:send-receive-real sinfo apath dbname cmd params)))))

;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed
;; sometime in the future
;;
(define (rmt:send-receive-real sinfo apath dbname cmd params)
  (let* ((conn (rmt:get-conn sinfo apath dbname)))
    (assert conn "FATAL: rmt:send-receive-real called without the needed channels opened")
    (let* ((key     #f)
	   (payload `((cmd    . ,cmd)
		      (key    . ,(conndat-srvkey conn))
		      (params . ,params)))

	   (res      (send-receive conn cmd payload)))
      (if (member res '("#<unspecified>")) ;; TODO - fix this in string->sexpr
	  #f
	  (string->sexpr res)))))

;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed
;; sometime in the future.
;;
;; Purpose - call the main.db server and request a server be started
;; for the given area path and dbname
;;







|
|


|

>
|


|







354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
	  (if rid (rmt:general-open-connection sinfo apath dbname))
	  (rmt:send-receive-real sinfo apath dbname cmd params)))))

;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed
;; sometime in the future
;;
(define (rmt:send-receive-real sinfo apath dbname cmd params)
  (let* ((cdat (rmt:get-conn sinfo apath dbname)))
    (assert cdat "FATAL: rmt:send-receive-real called without the needed channels opened")
    (let* ((key     #f)
	   (payload `((cmd    . ,cmd)
		      (key    . ,(conndat-srvkey cdat))
		      (params . ,params)))
	   (uconn    (servdat-uconn sinfo))
	   (res      (send-receive uconn (conndat-hostport cdat) cmd payload)))
      (if (member res '("#<unspecified>")) ;; TODO - fix this in string->sexpr
	  #f
	  res))))

;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed
;; sometime in the future.
;;
;; Purpose - call the main.db server and request a server be started
;; for the given area path and dbname
;;
1642
1643
1644
1645
1646
1647
1648

1649
1650
1651
1652
1653
1654
1655
1656
  (debug:print 2 *default-log-port* "PID: "(current-process-id)". Attempting to start the server ...")
  (if (and *db-serv-info*
	   (servdat-uconn *db-serv-info*))
      (let* ((uconn (servdat-uconn *db-serv-info*)))
	(wait-and-close uconn))
      (let* ((port            (portlogger:open-run-close portlogger:find-port))
	     (handler-proc    (lambda (rem-host-port qrykey cmd params) ;;

				(api:execute-requests *dbstruct-db* cmd params))))
	;; (api:process-request *dbstuct-db* 
	(if (not *db-serv-info*)
	    (set! *db-serv-info* (make-servdat host: hostn port: port)))
	(let* ((uconn (run-listener handler-proc port))
	       (rport (udat-port uconn))) ;; the real port
	  (servdat-host-set! *db-serv-info* hostn)
	  (servdat-port-set! *db-serv-info* rport)







>
|







1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
  (debug:print 2 *default-log-port* "PID: "(current-process-id)". Attempting to start the server ...")
  (if (and *db-serv-info*
	   (servdat-uconn *db-serv-info*))
      (let* ((uconn (servdat-uconn *db-serv-info*)))
	(wait-and-close uconn))
      (let* ((port            (portlogger:open-run-close portlogger:find-port))
	     (handler-proc    (lambda (rem-host-port qrykey cmd params) ;;
				(let* ((prms (alist-ref 'params params)))
				  (api:execute-requests *dbstruct-db* cmd prms #;params)))))
	;; (api:process-request *dbstuct-db* 
	(if (not *db-serv-info*)
	    (set! *db-serv-info* (make-servdat host: hostn port: port)))
	(let* ((uconn (run-listener handler-proc port))
	       (rport (udat-port uconn))) ;; the real port
	  (servdat-host-set! *db-serv-info* hostn)
	  (servdat-port-set! *db-serv-info* rport)
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
	
(define (server-ready? uconn host-port key) ;; server-address is host:port
  (let* ((data (sexpr->string  `((cmd . ping)
				 (key . ,key)
				 (params . ()))))
	 (res  (send-receive uconn host-port 'ping data)))
    (if res
	(string->sexpr res)
	res)))

; from the pkts return servers associated with dbpath
;; NOTE: Only one can be alive - have to check on each
;;       in the list of pkts returned
;;
(define (get-viable-servers serv-pkts dbpath)







|







1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
	
(define (server-ready? uconn host-port key) ;; server-address is host:port
  (let* ((data (sexpr->string  `((cmd . ping)
				 (key . ,key)
				 (params . ()))))
	 (res  (send-receive uconn host-port 'ping data)))
    (if res
	(car res)
	res)))

; from the pkts return servers associated with dbpath
;; NOTE: Only one can be alive - have to check on each
;;       in the list of pkts returned
;;
(define (get-viable-servers serv-pkts dbpath)

Modified tests/unittests/basicserver.scm from [621aa95c92] to [eb62de6943].

23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55










56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72

73
74
75
76
77
78
79
80
;;  ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0)

(import rmtmod trace http-client apimod dbmod
	launchmod srfi-69 ulex system-information)

(trace-call-sites #t)
(trace
 get-the-server
 ;; db:get-dbdat
 ;; rmt:find-main-server
;;  rmt:send-receive-real
;;  rmt:send-receive
 ;; sexpr->string
 server-ready?
 ;; rmt:register-server
 api:run-server-process
 rmt:open-main-connection
 ;; rmt:general-open-connection
 ;; rmt:get-conny
 ;; common:watchdog
 ;; rmt:find-main-server
 ;; get-all-server-pkts
 ;; get-viable-servers
 ;; get-best-candidate
 ;; api:run-server-process
 ;; rmt:run
 ;; rmt:try-start-server
 ;;
 ;; ulex
 ;;
 wait-and-close
 run-listener
 )











(test #f #t (servdat? (let ((s (make-servdat)))
			  (set! *servdat* s)
			  s)))
(test #f #f (rmt:get-conn *servdat* *toppath* ".db/main.db"))
(test #f #f (rmt:find-main-server *servdat* *toppath* ".db/main.db"))
(define th1 (make-thread (lambda ()
			   (rmt:run (get-host-name)))
			 "rmt:run thread"))
(thread-start! th1)
(thread-sleep! 0.5) ;; give things some time to get going
;; switch to *db-serv-info* instead of *servdat*
(define *uconn* (servdat-uconn *db-serv-info*))
(print "*uconn*: " *uconn*)
(test #f #t (ulex-listener? (servdat-uconn *db-serv-info*)))
(test #f #t (string? (udat-host-port *uconn*)))


(test #f #t (server-ready? *db-serv-dat* (udat-host-port *db-serv-dat*)))
  
(test #f #t (rmt:open-main-connection *db-serv-info* *toppath*))
;; (pp (hash-table->alist (remotedat-conns *db-serv-info*)))
(test #f #t (conndat? (rmt:get-conn *db-serv-info* *toppath* ".db/main.db")))
(exit)

(define *main*  (rmt:get-conn *db-serv-info* *toppath* ".db/main.db"))







|

|




















|
|

>
>
>
>
>
>
>
>
>
>

















>
|







23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
;;  ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0)

(import rmtmod trace http-client apimod dbmod
	launchmod srfi-69 ulex system-information)

(trace-call-sites #t)
(trace
 ;; get-the-server
 ;; db:get-dbdat
 rmt:find-main-server
;;  rmt:send-receive-real
;;  rmt:send-receive
 ;; sexpr->string
 server-ready?
 ;; rmt:register-server
 api:run-server-process
 rmt:open-main-connection
 ;; rmt:general-open-connection
 ;; rmt:get-conny
 ;; common:watchdog
 ;; rmt:find-main-server
 ;; get-all-server-pkts
 ;; get-viable-servers
 ;; get-best-candidate
 ;; api:run-server-process
 ;; rmt:run
 ;; rmt:try-start-server
 ;;
 ;; ulex
 ;;
 ;; wait-and-close
 ;; run-listener
 )

(define-syntax run-in-thread
  (syntax-rules ()
    ((_ body ...)
     (let ((th1 (make-thread (lambda ()
			       body ...)
			     "the thread")))
       (thread-start! th1)
       (thread-join! th1)))))


(test #f #t (servdat? (let ((s (make-servdat)))
			  (set! *servdat* s)
			  s)))
(test #f #f (rmt:get-conn *servdat* *toppath* ".db/main.db"))
(test #f #f (rmt:find-main-server *servdat* *toppath* ".db/main.db"))
(define th1 (make-thread (lambda ()
			   (rmt:run (get-host-name)))
			 "rmt:run thread"))
(thread-start! th1)
(thread-sleep! 0.5) ;; give things some time to get going
;; switch to *db-serv-info* instead of *servdat*
(define *uconn* (servdat-uconn *db-serv-info*))
(print "*uconn*: " *uconn*)
(test #f #t (ulex-listener? (servdat-uconn *db-serv-info*)))
(test #f #t (string? (udat-host-port *uconn*)))

(run-in-thread
 (test #f #t (server-ready? *uconn* (udat-host-port *uconn*) (servdat-uuid *db-serv-info*))))
  
(test #f #t (rmt:open-main-connection *db-serv-info* *toppath*))
;; (pp (hash-table->alist (remotedat-conns *db-serv-info*)))
(test #f #t (conndat? (rmt:get-conn *db-serv-info* *toppath* ".db/main.db")))
(exit)

(define *main*  (rmt:get-conn *db-serv-info* *toppath* ".db/main.db"))

Modified ulex/ulex.scm from [f7e86349bb] to [afccb56e89].

23
24
25
26
27
28
29


30
31
32
33
34
35
36
;; NOTES:
;;   Why sql-de-lite and not say, dbi?  - performance mostly, then simplicity.
;;
;;======================================================================

(module ulex
    (


     
     run-listener     ;; (run-listener handler-proc [port]) => uconn

     ;; NOTE: handler-proc params;
     ;;       (handler-proc rem-host-port qrykey cmd params)

     send-receive     ;; (send-receive uconn host-port cmd data)







>
>







23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
;; NOTES:
;;   Why sql-de-lite and not say, dbi?  - performance mostly, then simplicity.
;;
;;======================================================================

(module ulex
    (
     
     ;; NOTE: looking for the handler proc - find the run-listener :)
     
     run-listener     ;; (run-listener handler-proc [port]) => uconn

     ;; NOTE: handler-proc params;
     ;;       (handler-proc rem-host-port qrykey cmd params)

     send-receive     ;; (send-receive uconn host-port cmd data)