Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -20,21 +20,23 @@
SHELL=/bin/bash
PREFIX=$(PWD)
CSCOPTS=
INSTALL=install
SRCFILES = common.scm items.scm launch.scm ods.scm runconfig.scm \
- server.scm configf.scm db.scm keys.scm margs.scm \
- process.scm runs.scm tasks.scm tests.scm genexample.scm \
- http-transport.scm tdb.scm client.scm mt.scm \
- ezsteps.scm lock-queue.scm rmt.scm api.scm \
- subrun.scm portlogger.scm archive.scm env.scm \
- diff-report.scm cgisetup/models/pgdb.scm
+ configf.scm db.scm keys.scm margs.scm process.scm runs.scm \
+ tasks.scm tests.scm genexample.scm tdb.scm mt.scm \
+ ezsteps.scm lock-queue.scm api.scm subrun.scm \
+ portlogger.scm archive.scm env.scm diff-report.scm \
+ cgisetup/models/pgdb.scm
+
+# server.scm http-transport.scm client.scm rmt.scm
# module source files
-MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm
+MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm \
+ servermod.scm clientmod.scm rmtmod.scm
-all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut tcmt
+all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut
# dbmod.import.o is just a hack here
mofiles/dbfile.o : mofiles/debugprint.o mofiles/commonmod.o dbmod.import.o
db.o : dbmod.import.o
mofiles/debugprint.o : mofiles/mtargs.o
Index: api.scm
==================================================================
--- api.scm
+++ api.scm
@@ -21,18 +21,19 @@
;;======================================================================
(use srfi-69 posix)
(declare (unit api))
-(declare (uses rmt))
+(declare (uses rmtmod))
(declare (uses db))
(declare (uses dbmod))
(declare (uses dbfile))
(declare (uses tasks))
(import dbmod)
(import dbfile)
+(import rmtmod)
;; allow these queries through without starting a server
;;
(define api:read-only-queries
'(get-key-val-pairs
Index: client.scm
==================================================================
--- client.scm
+++ client.scm
@@ -28,135 +28,136 @@
(declare (uses common))
(declare (uses db))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
-(module client
-*
-
-)
-
-(import client)
-
-(include "common_records.scm")
-(include "db_records.scm")
-
-;; client:get-signature
-(define (client:get-signature)
- (if *my-client-signature* *my-client-signature*
- (let ((sig (conc (get-host-name) " " (current-process-id))))
- (set! *my-client-signature* sig)
- *my-client-signature*)))
-
-;; Not currently used! But, I think it *should* be used!!!
-#;(define (client:logout serverdat)
- (let ((ok (and (socket? serverdat)
- (cdb:logout serverdat *toppath* (client:get-signature)))))
- ok))
-
-;; Do all the connection work, look up the transport type and set up the
-;; connection if required.
-;;
-;; There are two scenarios.
-;; 1. We are a test manager and we received *transport-type* and *runremote* via cmdline
-;; 2. We are a run tests, list runs or other interactive process and we must figure out
-;; *transport-type* and *runremote* from the monitor.db
-;;
-;; client:setup
-;;
-;; lookup_server, need to remove *runremote* stuff
-;;
-
-;;(define (http-transport:server-dat-make-url runremote)
-(define (client:get-url runremote)
- (if (and (remote-iface runremote)
- (remote-port runremote))
- (conc "http://"
- (remote-iface runremote)
- ":"
- (remote-port runremote))
- #f))
-
-(define (client:setup areapath runremote #!key (remaining-tries 100) (failed-connects 0)(area-dat #f))
- (mutex-lock! *rmt-mutex*)
- (let ((res (client:setup-http areapath runremote remaining-tries: remaining-tries failed-connects: failed-connects area-dat: area-dat)))
- (mutex-unlock! *rmt-mutex*)
- res))
-
-(define (client:setup-http areapath runremote #!key (remaining-tries 100) (failed-connects 0))
- (debug:print-info 2 *default-log-port* "client:setup remaining-tries=" remaining-tries)
- (server:start-and-wait areapath)
- (if (<= remaining-tries 0)
- (begin
- (debug:print-error 0 *default-log-port* "failed to start or connect to server")
- (exit 1))
- ;;
- ;; Alternatively here, we can get the list of candidate servers and work our way
- ;; through them searching for a good one.
- ;;
- (let* ((server-dat (server:choose-server areapath 'best))) ;; list host port start-time server-id pid
-;; (runremote (or area-dat *runremote*)))
- (if (not server-dat) ;; no server found
- (begin
- (if (< remaining-tries 99)(thread-sleep! 1)) ;; obviously it needs time
- (client:setup-http areapath runremote remaining-tries: (- remaining-tries 1)))
- (match server-dat
- ((host port start-time server-id pid)
- (debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
- (if (not runremote)
- (begin
- ;; Here we are creating a runremote where there was none or it was clobbered with #f
- ;;
- (set! runremote (make-remote))
- (let* ((server-info (server:check-if-running areapath)))
- (remote-server-info-set! runremote server-info)
- (if server-info
- (begin
- (remote-server-url-set! runremote (server:record->url server-info))
- (remote-server-id-set! runremote (server:record->id server-info)))))))
- ;; at this point we have a runremote
- (if (and host port server-id)
- (let* ((nada (client:connect host port server-id runremote))
- (ping-res (rmt:login-no-auto-client-setup runremote)))
- (if ping-res
- (if runremote
- (begin
- (debug:print-info 2 *default-log-port* "connected to " (client:get-url runremote))
- runremote)
- (client:setup-http areapath runremote remaining-tries: (- remaining-tries 1)))
- (begin ;; login failed but have a server record, clean out the record and try again
- (debug:print-info 0 *default-log-port* "client:setup, login unsuccessful, will attempt to start server ... ping-res=" ping-res ", server-dat=" server-dat) ;; had runid. Fixes part of Randy;s ticket 1405717332
- (http-transport:close-connections runremote)
- (thread-sleep! 1)
- (client:setup-http areapath runremote remaining-tries: (- remaining-tries 1))
- )))
- (begin ;; no server registered
- ;; (server:kind-run areapath)
- (server:start-and-wait areapath)
- (debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries)
- (thread-sleep! 1) ;; (+ 5 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms.
- (client:setup-http areapath runremote remaining-tries: (- remaining-tries 1)))))
- (else
- (debug:print 0 *default-log-port* "ERROR: malformed server-dat="server-dat)))))))
-
-;;
-;; connect - stored in remote-condat
-;;
-;; (define (http-transport:client-connect iface port server-id runremote)
-(define (client:connect iface port server-id runremote-in)
- (let* ((runremote (or runremote-in
- (make-runremote))))
- (debug:print-info 2 *default-log-port* "Connecting to server at "iface":"port", id "server-id)
- (let* ((api-url (conc "http://" iface ":" port "/api"))
- (api-uri (uri-reference (conc "http://" iface ":" port "/api")))
- (api-req (make-request method: 'POST uri: api-uri)))
- ;; (server-dat (vector iface port api-uri api-url api-req (current-seconds) server-id)))
- (remote-iface-set! runremote iface)
- (remote-port-set! runremote port)
- (remote-server-id-set! runremote server-id)
- (remote-connect-time-set! runremote (current-seconds))
- (remote-last-access-set! runremote (current-seconds))
- (remote-api-url-set! runremote api-url)
- (remote-api-uri-set! runremote api-uri)
- (remote-api-req-set! runremote api-req)
- runremote)))
-
+;; (module client
+;; *
+;;
+;; )
+;;
+;; (import client)
+;;
+;; (include "common_records.scm")
+;; (include "db_records.scm")
+;;
+;; ;; client:get-signature
+;; (define (client:get-signature)
+;; (if *my-client-signature* *my-client-signature*
+;; (let ((sig (conc (get-host-name) " " (current-process-id))))
+;; (set! *my-client-signature* sig)
+;; *my-client-signature*)))
+;;
+;; ;; Not currently used! But, I think it *should* be used!!!
+;; #;(define (client:logout serverdat)
+;; (let ((ok (and (socket? serverdat)
+;; (cdb:logout serverdat *toppath* (client:get-signature)))))
+;; ok))
+;;
+;; ;; Do all the connection work, look up the transport type and set up the
+;; ;; connection if required.
+;; ;;
+;; ;; There are two scenarios.
+;; ;; 1. We are a test manager and we received *transport-type* and *runremote* via cmdline
+;; ;; 2. We are a run tests, list runs or other interactive process and we must figure out
+;; ;; *transport-type* and *runremote* from the monitor.db
+;; ;;
+;; ;; client:setup
+;; ;;
+;; ;; lookup_server, need to remove *runremote* stuff
+;; ;;
+;;
+;; ;;(define (http-transport:server-dat-make-url runremote)
+;; (define (client:get-url runremote)
+;; (if (and (remote-iface runremote)
+;; (remote-port runremote))
+;; (conc "http://"
+;; (remote-iface runremote)
+;; ":"
+;; (remote-port runremote))
+;; #f))
+;;
+;; (define (client:setup areapath runremote #!key (remaining-tries 100) (failed-connects 0)(area-dat #f))
+;; (mutex-lock! *rmt-mutex*)
+;; (let ((res (client:setup-http areapath runremote remaining-tries: remaining-tries failed-connects: failed-connects area-dat: area-dat)))
+;; (mutex-unlock! *rmt-mutex*)
+;; res))
+;;
+;; (define (client:setup-http areapath runremote #!key (remaining-tries 100) (failed-connects 0))
+;; (debug:print-info 2 *default-log-port* "client:setup remaining-tries=" remaining-tries)
+;; (server:start-and-wait areapath)
+;; (if (<= remaining-tries 0)
+;; (begin
+;; (debug:print-error 0 *default-log-port* "failed to start or connect to server")
+;; (exit 1))
+;; ;;
+;; ;; Alternatively here, we can get the list of candidate servers and work our way
+;; ;; through them searching for a good one.
+;; ;;
+;; (let* ((server-dat (server:choose-server areapath 'best))) ;; list host port start-time server-id pid
+;; ;; (runremote (or area-dat *runremote*)))
+;; (if (not server-dat) ;; no server found
+;; (begin
+;; (if (< remaining-tries 99)(thread-sleep! 1)) ;; obviously it needs time
+;; (client:setup-http areapath runremote remaining-tries: (- remaining-tries 1)))
+;; (match server-dat
+;; ((host port start-time server-id pid)
+;; (debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
+;; (if (not runremote)
+;; (begin
+;; ;; Here we are creating a runremote where there was none or it was clobbered with #f
+;; ;;
+;; (set! runremote (make-remote))
+;; (let* ((server-info (server:check-if-running areapath)))
+;; (remote-server-info-set! runremote server-info)
+;; (if server-info
+;; (begin
+;; (remote-server-url-set! runremote (server:record->url server-info))
+;; (remote-server-id-set! runremote (server:record->id server-info)))))))
+;; ;; at this point we have a runremote
+;; (if (and host port server-id)
+;; (let* ((nada (client:connect host port server-id runremote))
+;; (ping-res (rmt:login-no-auto-client-setup runremote)))
+;; (if ping-res
+;; (if runremote
+;; (begin
+;; (debug:print-info 2 *default-log-port* "connected to " (client:get-url runremote))
+;; runremote)
+;; (client:setup-http areapath runremote remaining-tries: (- remaining-tries 1)))
+;; (begin ;; login failed but have a server record, clean out the record and try again
+;; (debug:print-info 0 *default-log-port* "client:setup, login unsuccessful, will attempt to start server ... ping-res=" ping-res ", server-dat=" server-dat) ;; had runid. Fixes part of Randy;s ticket 1405717332
+;; (http-transport:close-connections runremote)
+;; (thread-sleep! 1)
+;; (client:setup-http areapath runremote remaining-tries: (- remaining-tries 1))
+;; )))
+;; (begin ;; no server registered
+;; ;; (server:kind-run areapath)
+;; (server:start-and-wait areapath)
+;; (debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries)
+;; (thread-sleep! 1) ;; (+ 5 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms.
+;; (client:setup-http areapath runremote remaining-tries: (- remaining-tries 1)))))
+;; (else
+;; (debug:print 0 *default-log-port* "ERROR: malformed server-dat="server-dat)))))))
+;;
+;; ;;
+;; ;; connect - stored in remote-condat
+;; ;;
+;; ;; (define (http-transport:client-connect iface port server-id runremote)
+;; (define (client:connect iface port server-id runremote-in)
+;; (let* ((runremote (or runremote-in
+;; (make-runremote))))
+;; (debug:print-info 2 *default-log-port* "Connecting to server at "iface":"port", id "server-id)
+;; (let* ((api-url (conc "http://" iface ":" port "/api"))
+;; (api-uri (uri-reference (conc "http://" iface ":" port "/api")))
+;; (api-req (make-request method: 'POST uri: api-uri)))
+;; ;; (server-dat (vector iface port api-uri api-url api-req (current-seconds) server-id)))
+;; (remote-iface-set! runremote iface)
+;; (remote-port-set! runremote port)
+;; (remote-server-id-set! runremote server-id)
+;; (remote-connect-time-set! runremote (current-seconds))
+;; (remote-last-access-set! runremote (current-seconds))
+;; (remote-api-url-set! runremote api-url)
+;; (remote-api-uri-set! runremote api-uri)
+;; (remote-api-req-set! runremote api-req)
+;; runremote)))
+;;
+;;
ADDED clientmod.scm
Index: clientmod.scm
==================================================================
--- /dev/null
+++ clientmod.scm
@@ -0,0 +1,33 @@
+
+;; Copyright 2006-2012, 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 .
+
+;;======================================================================
+;; C L I E N T S
+;;======================================================================
+
+;;(use srfi-18 extras tcp s11n srfi-1 posix regex srfi-69 hostinfo md5
+;; message-digest matchable spiffy uri-common intarweb http-client
+;; spiffy-request-vars uri-common intarweb directory-utils)
+
+(declare (unit clientmod))
+
+(module clientmod
+*
+
+)
+
Index: dashboard-context-menu.scm
==================================================================
--- dashboard-context-menu.scm
+++ dashboard-context-menu.scm
@@ -34,11 +34,11 @@
(declare (unit dashboard-context-menu))
(declare (uses common))
(declare (uses db))
(declare (uses gutils))
-(declare (uses rmt))
+(declare (uses rmtmod))
(declare (uses ezsteps))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrun))
Index: dashboard-tests.scm
==================================================================
--- dashboard-tests.scm
+++ dashboard-tests.scm
@@ -33,11 +33,11 @@
(declare (unit dashboard-tests))
(declare (uses common))
(declare (uses db))
(declare (uses gutils))
-(declare (uses rmt))
+(declare (uses rmtmod))
(declare (uses ezsteps))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrun))
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -51,11 +51,11 @@
(declare (uses dbmod))
;; (declare (uses debugprint))
(declare (uses dbfile))
(declare (uses keys))
(declare (uses ods))
-(declare (uses client))
+;; (declare (uses client))
(declare (uses mt))
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
Index: diff-report.scm
==================================================================
--- diff-report.scm
+++ diff-report.scm
@@ -16,11 +16,11 @@
;; along with Megatest. If not, see .
;;
(declare (unit diff-report))
(declare (uses common))
-(declare (uses rmt))
+(declare (uses rmtmod))
(include "common_records.scm")
(use matchable)
(use fmt)
(use ducttape-lib)
Index: http-transport.scm
==================================================================
--- http-transport.scm
+++ http-transport.scm
@@ -1,6 +1,5 @@
-
;; Copyright 2006-2012, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest is free software: you can redistribute it and/or modify
@@ -14,680 +13,681 @@
;; 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 .
-(require-extension (srfi 18) extras tcp s11n)
-
-
-(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras)
-
-(use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing)
-
-;; Configurations for server
-(tcp-buffer-size 2048)
-(max-connections 2048)
-
+;; (require-extension (srfi 18) extras tcp s11n)
+;;
+;;
+;; (use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras)
+;;
+;; (use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing)
+;;
+;; ;; Configurations for server
+;; (tcp-buffer-size 2048)
+;; (max-connections 2048)
+;;
(declare (unit http-transport))
-
-(declare (uses common))
-(declare (uses db))
-(declare (uses tests))
-(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
-(declare (uses server))
-;; (declare (uses daemon))
-(declare (uses portlogger))
-(declare (uses rmt))
-(declare (uses dbfile))
-(declare (uses commonmod))
-
-(include "common_records.scm")
-(include "db_records.scm")
-(include "js-path.scm")
-
-(import dbfile commonmod)
-
-(require-library stml)
-(define (http-transport:make-server-url hostport)
- (if (not hostport)
- #f
- (conc "http://" (car hostport) ":" (cadr hostport))))
-
-(define *server-loop-heart-beat* (current-seconds))
-
-;;======================================================================
-;; S E R V E R
-;; ======================================================================
-
-;; Call this to start the actual server
-;;
-
-(define *db:process-queue-mutex* (make-mutex))
-
-(define (http-transport:run hostn)
- ;; Configurations for server
- (tcp-buffer-size 2048)
- (max-connections 2048)
- (debug:print 2 *default-log-port* "Attempting to start the server ...")
- (let* ((db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily
- (hostname (get-host-name))
- (ipaddrstr (let ((ipstr (if (string=? "-" hostn)
- ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
- (server:get-best-guess-address hostname)
- #f)))
- (if ipstr ipstr hostn))) ;; hostname)))
- (start-port (portlogger:open-run-close portlogger:find-port))
- (link-tree-path (common:get-linktree))
- (tmp-area (common:get-db-tmp-area))
- (start-file (conc tmp-area "/.server-start")))
- (debug:print-info 0 *default-log-port* "portlogger recommended port: " start-port)
- ;; set some parameters for the server
- (root-path (if link-tree-path
- link-tree-path
- (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP!
- (handle-directory spiffy-directory-listing)
- (handle-exception (lambda (exn chain)
- (signal (make-composite-condition
- (make-property-condition
- 'server
- 'message "server error")))))
-
- ;; http-transport:handle-directory) ;; simple-directory-handler)
- ;; Setup the web server and a /ctrl interface
- ;;
- (vhost-map `(((* any) . ,(lambda (continue)
- ;; open the db on the first call
- ;; This is were we set up the database connections
- (let* (($ (request-vars source: 'both))
- (dat ($ 'dat))
- (res #f))
- (cond
- ((equal? (uri-path (request-uri (current-request)))
- '(/ "api"))
- (send-response body: (api:process-request *dbstruct-dbs* $) ;; the $ is the request vars proc
- headers: '((content-type text/plain)))
- (mutex-lock! *heartbeat-mutex*)
- (set! *db-last-access* (current-seconds))
- (mutex-unlock! *heartbeat-mutex*))
- ((equal? (uri-path (request-uri (current-request)))
- '(/ ""))
- (send-response body: (http-transport:main-page)))
- ((equal? (uri-path (request-uri (current-request)))
- '(/ "json_api"))
- (send-response body: (http-transport:main-page)))
- ((equal? (uri-path (request-uri (current-request)))
- '(/ "runs"))
- (send-response body: (http-transport:main-page)))
- ((equal? (uri-path (request-uri (current-request)))
- '(/ any))
- (send-response body: "hey there!\n"
- headers: '((content-type text/plain))))
- ((equal? (uri-path (request-uri (current-request)))
- '(/ "hey"))
- (send-response body: "hey there!\n"
- headers: '((content-type text/plain))))
- ((equal? (uri-path (request-uri (current-request)))
- '(/ "jquery3.1.0.js"))
- (send-response body: (http-transport:show-jquery)
- headers: '((content-type application/javascript))))
- ((equal? (uri-path (request-uri (current-request)))
- '(/ "test_log"))
- (send-response body: (http-transport:html-test-log $)
- headers: '((content-type text/HTML))))
- ((equal? (uri-path (request-uri (current-request)))
- '(/ "dashboard"))
- (send-response body: (http-transport:html-dboard $)
- headers: '((content-type text/HTML))))
- (else (continue))))))))
- (handle-exceptions
- exn
- (debug:print 0 *default-log-port* "Failed to create file " start-file ", exn=" exn)
- (with-output-to-file start-file (lambda ()(print (current-process-id)))))
- (http-transport:try-start-server ipaddrstr start-port)))
-
-;; This is recursively run by http-transport:run until sucessful
-;;
-(define (http-transport:try-start-server ipaddrstr portnum)
- (let ((config-hostname (configf:lookup *configdat* "server" "hostname"))
- (config-use-proxy (equal? (configf:lookup *configdat* "client" "use-http_proxy") "yes")))
- (if (not config-use-proxy)
- (determine-proxy (constantly #f)))
- (debug:print-info 0 *default-log-port* "http-transport:try-start-server time=" (seconds->time-string (current-seconds)) " ipaddrsstr=" ipaddrstr " portnum=" portnum " config-hostname=" config-hostname)
- (handle-exceptions
- exn
- (begin
- ;; (print-error-message exn)
- (if (< portnum 64000)
- (begin
- (debug:print 0 *default-log-port* "WARNING: attempt to start server failed. Trying again ...")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (debug:print 5 *default-log-port* "exn=" (condition->list exn))
- (portlogger:open-run-close portlogger:set-failed portnum)
- (debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port")
- (thread-sleep! 0.1)
-
- ;; get_next_port goes here
- (http-transport:try-start-server ipaddrstr
- (portlogger:open-run-close portlogger:find-port)))
- (begin
- (debug:print 0 *default-log-port* "ERROR: Tried and tried but could not start the server"))))
- ;; any error in following steps will result in a retry
- (set! *server-info* (list ipaddrstr portnum))
- (debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum)
- ;; This starts the spiffy server
- ;; NEED WAY TO SET IP TO #f TO BIND ALL
- ;; (start-server bind-address: ipaddrstr port: portnum)
- (if config-hostname ;; this is a hint to bind directly
- (start-server port: portnum) ;; bind-address: (if (equal? config-hostname "-")
- ;; ipaddrstr
- ;; config-hostname))
- (start-server port: portnum))
- (portlogger:open-run-close portlogger:set-port portnum "released")
- (debug:print 1 *default-log-port* "INFO: server has been stopped"))))
-
-;;======================================================================
-;; S E R V E R U T I L I T I E S
-;;======================================================================
-
-;;======================================================================
-;; C L I E N T S
-;;======================================================================
-
-(define *http-mutex* (make-mutex))
-
-;; NOTE: Large block of code from 32436b426188080f72fceb6894af541fbad9921e removed here
-;; I'm pretty sure it is defunct.
-
-;; This next block all imported en-mass from the api branch
-(define *http-requests-in-progress* 0)
-(define *http-connections-next-cleanup* (current-seconds))
-
-(define (http-transport:get-time-to-cleanup)
- (let ((res #f))
- (mutex-lock! *http-mutex*)
- (set! res (> (current-seconds) *http-connections-next-cleanup*))
- (mutex-unlock! *http-mutex*)
- res))
-
-(define (http-transport:inc-requests-count)
- (mutex-lock! *http-mutex*)
- (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*))
- ;; Use this opportunity to slow things down iff there are too many requests in flight
- (if (> *http-requests-in-progress* 5)
- (begin
- (debug:print-info 0 *default-log-port* "Whoa there buddy, ease up...")
- (thread-sleep! 1)))
- (mutex-unlock! *http-mutex*))
-
-(define (http-transport:dec-requests-count proc)
- (mutex-lock! *http-mutex*)
- (proc)
- (set! *http-requests-in-progress* (- *http-requests-in-progress* 1))
- (mutex-unlock! *http-mutex*))
-
-(define (http-transport:dec-requests-count-and-close-all-connections)
- (set! *http-requests-in-progress* (- *http-requests-in-progress* 1))
- (let loop ((etime (+ (current-seconds) 5))) ;; give up in five seconds
- (if (> *http-requests-in-progress* 0)
- (if (> etime (current-seconds))
- (begin
- (thread-sleep! 0.05)
- (loop etime))
- (debug:print-error 0 *default-log-port* "requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections"))
- (close-all-connections!)))
- (set! *http-connections-next-cleanup* (+ (current-seconds) 10))
- (mutex-unlock! *http-mutex*))
-
-(define (http-transport:inc-requests-and-prep-to-close-all-connections)
- (mutex-lock! *http-mutex*)
- (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*)))
-
-;; Send "cmd" with json payload "params" to serverdat and receive result
-;;
-(define (http-transport:client-api-send-receive run-id runremote cmd params #!key (numretries 3))
- (assert (remote? runremote) "FATAL: http-transport:client-api-send-receive called with serverdat="serverdat)
- (let* ((fullurl (remote-api-req runremote))
- (res (vector #f "uninitialized"))
- (success #t)
- (sparams (db:obj->string params transport: 'http))
- (server-id (remote-server-id runremote)))
- (debug:print-info 11 *default-log-port* "cmd=" cmd " fullurl=" fullurl " server-id=" server-id " current time:" (current-seconds))
-
- ;; set up the http-client here
- (max-retry-attempts 1)
- ;; consider all requests indempotent
- (retry-request? (lambda (request)
- #f))
- ;; send the data and get the response
- ;; extract the needed info from the http data and
- ;; process and return it.
- (let* ((send-recieve (lambda ()
- (mutex-lock! *http-mutex*)
- ;; (condition-case (with-input-from-request "http://localhost"; #f read-lines)
- ;; ((exn http client-error) e (print e)))
- (set! res (vector ;;; DON'T FORGET - THIS IS THE CLIENT SIDE! NOTE: consider moving this to client.scm since we are only supporting http transport at this time.
- success
- (db:string->obj
- (handle-exceptions
- exn
- (let ((call-chain (get-call-chain))
- (msg ((condition-property-accessor 'exn 'message) exn)))
- (set! success #f)
- (if (debug:debug-mode 1)
- (debug:print-info 0 *default-log-port* "couldn't talk to server, trying again ...")
- (begin
- (debug:print 0 *default-log-port* "WARNING: failure in with-input-from-request to " fullurl ".")
- (debug:print 0 *default-log-port* " message: " msg ", exn=" exn)
- (debug:print 0 *default-log-port* " cmd: " cmd " params: " params " key:" (or server-id "thekey"))
- (debug:print 0 *default-log-port* " call-chain: " call-chain)))
- ;; what if another thread is communicating ok? Can't happen due to mutex
- (http-transport:close-connections runremote)
- (mutex-unlock! *http-mutex*)
- ;; (close-connection! fullurl)
- (db:obj->string #f))
- (with-input-from-request ;; was dat
- fullurl
- (list (cons 'key (or server-id "thekey"))
- (cons 'cmd cmd)
- (cons 'params sparams))
- read-string))
- transport: 'http)
- 0)) ;; added this speculatively
- ;; Shouldn't this be a call to the managed call-all-connections stuff above?
- ;; (close-all-connections!) ;; BUG? WHY IS THIS HERE? Are we failing to reuse connections?
- (mutex-unlock! *http-mutex*)
- ))
- (time-out (lambda ()
- (thread-sleep! 45)
- (debug:print 0 *default-log-port* "WARNING: send-receive took more than 45 seconds!!")
- #f))
- (th1 (make-thread send-recieve "with-input-from-request"))
- (th2 (make-thread time-out "time out")))
- (thread-start! th1)
- (thread-start! th2)
- (thread-join! th1)
- (vector-set! res 0 success)
- (thread-terminate! th2)
- (if (vector? res)
- (if (vector-ref res 0) ;; this is the first flag or the second flag?
- (let* ((res-dat (vector-ref res 1)))
- (if (and (string? res-dat) (string-contains res-dat "server-id mismatch"))
- (signal (make-composite-condition
- (make-property-condition
- 'servermismatch
- 'message (vector-ref res 1))))
- res)) ;; this is the *inner* vector? seriously? why?
- (if (debug:debug-mode 11)
- (let ((call-chain (get-call-chain))) ;; note: this code also called in nmsg-transport - consider consolidating it
- (print-call-chain (current-error-port))
- (debug:print-error 11 *default-log-port* "error above occured at server, res=" res) ;; " message: " ((condition-property-accessor 'exn 'message) exn))
- (debug:print 11 *default-log-port* " server call chain:")
- (pp (vector-ref res 1) (current-error-port))
- (signal (vector-ref res 0)))
- res))
- (signal (make-composite-condition
- (make-property-condition
- 'timeout
- 'message "nmsg-transport:client-api-send-receive-raw timed out talking to server")))))))
-
-;; careful closing of connections stored in *runremote*
-;;
-(define (http-transport:close-connections runremote)
- (if (remote? runremote)
- (let ((api-dat (remote-api-uri runremote)))
- (handle-exceptions
- exn
- (begin
- (print-call-chain *default-log-port*)
- (debug:print-error 0 *default-log-port* " closing connection failed with error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn))
- (if (args:any-defined? "-server" "-execute" "-run")
- (debug:print-info 0 *default-log-port* "Closing connections to "api-dat))
- (if api-dat (close-connection! api-dat))
- (remote-conndat-set! runremote #f)
- #t))
- #f))
-
-;; run http-transport:keep-running in a parallel thread to monitor that the db is being
-;; used and to shutdown after sometime if it is not.
-;;
-(define (http-transport:keep-running)
- ;; if none running or if > 20 seconds since
- ;; server last used then start shutdown
- ;; This thread waits for the server to come alive
- (debug:print-info 0 *default-log-port* "Starting the sync-back, keep alive thread in server")
- (let* ((servinfofile #f)
- (sdat #f)
- (no-sync-db (db:open-no-sync-db))
- (tmp-area (common:get-db-tmp-area))
- (started-file (conc tmp-area "/.server-started"))
- (server-start-time (current-seconds))
- (server-info (let loop ((start-time (current-seconds))
- (changed #t)
- (last-sdat "not this"))
- (begin ;; let ((sdat #f))
- (thread-sleep! 0.01)
- (debug:print-info 0 *default-log-port* "Waiting for server alive signature")
- (mutex-lock! *heartbeat-mutex*)
- (set! sdat *server-info*)
- (mutex-unlock! *heartbeat-mutex*)
- (if (and sdat
- (not changed)
- (> (- (current-seconds) start-time) 2))
- (let* ((servinfodir (server:get-servinfo-dir *toppath*)) ;; (conc *toppath*"/.servinfo"))
- (ipaddr (car sdat))
- (port (cadr sdat))
- (servinf (conc servinfodir"/"ipaddr":"port)))
- (set! servinfofile servinf)
- (if (not (file-exists? servinfodir))
- (create-directory servinfodir #t))
- (with-output-to-file servinf
- (lambda ()
- (let* ((serv-id (server:mk-signature)))
- (set! *server-id* serv-id)
- (print "SERVER STARTED: "ipaddr":"port" AT "(current-seconds)" server-id: "serv-id" pid: "(current-process-id))
- (print "started: "(seconds->year-week/day-time (current-seconds))))))
- (set! *on-exit-procs* (cons
- (lambda ()
- (delete-file* servinf))
- *on-exit-procs*))
- ;; put data about this server into a simple flat file host.port
- (debug:print-info 0 *default-log-port* "Received server alive signature")
- sdat)
- (begin
- (debug:print-info 0 *default-log-port* "Still waiting, last-sdat=" last-sdat)
- (sleep 4)
- (if (> (- (current-seconds) start-time) 120) ;; been waiting for two minutes
- (if sdat
- (let* ((ipaddr (car sdat))
- (port (cadr sdat))
- (servinf (conc (server:get-servinfo-dir *toppath*)"/"ipaddr":"port)))
- (debug:print-error 0 *default-log-port* "transport appears to have died, exiting server")
- (exit))
- (exit)
- )
- (loop start-time
- (equal? sdat last-sdat)
- sdat)))))))
- (iface (car server-info))
- (port (cadr server-info))
- (last-access 0)
- (server-timeout (server:expiration-timeout))
- (server-going #f)
- (server-log-file (args:get-arg "-log"))) ;; always set when we are a server
-
- (handle-exceptions
- exn
- (debug:print 0 *default-log-port* "Failed to create " started-file ", exn=" exn)
- (with-output-to-file started-file (lambda ()(print (current-process-id)))))
-
- (let loop ((count 0)
- (server-state 'available)
- (bad-sync-count 0)
- (start-time (current-milliseconds)))
-
- ;; Use this opportunity to sync the tmp db to megatest.db
- (if (not server-going) ;; *dbstruct-dbs*
- (begin
- (debug:print 0 *default-log-port* "SERVER: dbprep")
- (set! *dbstruct-dbs* (db:setup #t)) ;; run-id)) FIXME!!!
- (set! server-going #t)
- (debug:print 0 *default-log-port* "SERVER: running, megatest version: " (common:get-full-version))) ;; NOTE: the server is NOT yet marked as running in the log. We do that in the keep-running routine.
- (if (and no-sync-db
- (common:low-noise-print 10 "sync-all")) ;; cheesy way to reduce frequency of running sync :)
- (begin
- (if (common:low-noise-print 120 "sync-all-print")
- (debug:print 0 *default-log-port* "keep-running calling db:all-db-sync at " (time->string (seconds->local-time) "%H:%M:%S")))
- (db:all-db-sync *dbstruct-dbs*)
- )))
-
- ;; when things go wrong we don't want to be doing the various queries too often
- ;; so we strive to run this stuff only every four seconds or so.
- (let* ((sync-time (- (current-milliseconds) start-time))
- (rem-time (quotient (- 4000 sync-time) 1000)))
- (if (and (<= rem-time 4)
- (> rem-time 0))
- (thread-sleep! rem-time)))
-
- (if (< count 1) ;; 3x3 = 9 secs aprox
- (loop (+ count 1) 'running bad-sync-count (current-milliseconds)))
-
- ;; Check that iface and port have not changed (can happen if server port collides)
- (mutex-lock! *heartbeat-mutex*)
- (set! sdat *server-info*)
- (mutex-unlock! *heartbeat-mutex*)
-
- (if (not (equal? sdat (list iface port)))
- (let ((new-iface (car sdat))
- (new-port (cadr sdat)))
- (debug:print-info 0 *default-log-port* "WARNING: interface changed, refreshing iface and port info")
- (set! iface new-iface)
- (set! port new-port)
- (if (not *server-id*)
- (set! *server-id* (server:mk-signature)))
- (debug:print 0 *default-log-port* "SERVER STARTED: " iface ":" port " AT " (current-seconds) " server-id: " *server-id*)
- (flush-output *default-log-port*)))
-
- ;; Transfer *db-last-access* to last-access to use in checking that we are still alive
- (mutex-lock! *heartbeat-mutex*)
- (set! last-access *db-last-access*)
- (mutex-unlock! *heartbeat-mutex*)
-
- (if (common:low-noise-print 120 (conc "server running on " iface ":" port))
- (begin
- (if (not *server-id*)
- (set! *server-id* (server:mk-signature)))
- (debug:print 0 *default-log-port* (current-seconds) (current-directory) (current-process-id) (argv))
- (debug:print 0 *default-log-port* "SERVER STARTED: " iface ":" port " AT " (current-seconds) " server-id: " *server-id*)
- (flush-output *default-log-port*)))
- (if (common:low-noise-print 60 "dbstats")
- (begin
- (debug:print 0 *default-log-port* "Server stats:")
- (db:print-current-query-stats)))
- (let* ((hrs-since-start (/ (- (current-seconds) server-start-time) 3600)))
- (cond
- ((and *server-run*
- (> (+ last-access server-timeout)
- (current-seconds)))
- (if (common:low-noise-print 120 "server continuing")
- (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
- (let ((curr-time (current-seconds)))
- (handle-exceptions
- exn
- (debug:print 0 *default-log-port* "ERROR: Failed to change timestamp on info file " servinfofile ". Are you out of space on that disk? exn=" exn)
- (if (and ;; (< (- (current-seconds) server-start-time) 600) ;; run for ten minutes for experiment, 3600 thereafter
- (not *server-overloaded*)
- (file-exists? servinfofile))
- (change-file-times servinfofile curr-time curr-time)))
- (if (and (common:low-noise-print 120 "start new server")
- (> *api-process-request-count* 50)) ;; if this server is kind of busy start up another
- (begin
- (debug:print-info 0 *default-log-port* "Server is busy, api-count "*api-process-request-count*", start another if possible...")
- (server:kind-run *toppath*)
- (if (> *api-process-request-count* 100)
- (begin
- (debug:print-info 0 *default-log-port* "Server is overloaded at api-count=" *api-process-request-count*", removing "servinfofile)
- (delete-file* servinfofile)))))))
- (loop 0 server-state bad-sync-count (current-milliseconds)))
- (else
- (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access))
- (http-transport:server-shutdown port)))))))
-
-(define (http-transport:server-shutdown port)
- (begin
- ;;(BB> "http-transport:server-shutdown called")
- (debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id))
- ;;
- ;; start_shutdown
- ;;
- (set! *time-to-exit* #t) ;; tell on-exit to be fast as we've already cleaned up
- (portlogger:open-run-close portlogger:set-port port "released")
- (thread-sleep! 1)
-
- ;; (debug:print-info 0 *default-log-port* "Max cached queries was " *max-cache-size*)
- ;; (debug:print-info 0 *default-log-port* "Number of cached writes " *number-of-writes*)
- ;; (debug:print-info 0 *default-log-port* "Average cached write time "
- ;; (if (eq? *number-of-writes* 0)
- ;; "n/a (no writes)"
- ;; (/ *writes-total-delay*
- ;; *number-of-writes*))
- ;; " ms")
- ;; (debug:print-info 0 *default-log-port* "Number non-cached queries " *number-non-write-queries*)
- ;; (debug:print-info 0 *default-log-port* "Average non-cached time "
- ;; (if (eq? *number-non-write-queries* 0)
- ;; "n/a (no queries)"
- ;; (/ *total-non-write-delay*
- ;; *number-non-write-queries*))
- ;; " ms")
-
- (db:print-current-query-stats)
- #;(common:save-pkt `((action . exit)
- (T . server)
- (pid . ,(current-process-id)))
- *configdat* #t)
-
- ;; remove .servinfo file(s) here
-
- (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
- (exit)))
-
-;; all routes though here end in exit ...
-;;
-;; start_server?
-;;
-(define (http-transport:launch)
- ;; check the .servinfo directory, are there other servers running on this
- ;; or another host?
- (let* ((server-start-is-ok (server:minimal-check *toppath*)))
- (if (not server-start-is-ok)
- (begin
- (debug:print 0 *default-log-port* "ERROR: server start not ok, exiting now.")
- (exit 1))))
-
- ;; check that a server start is in progress, pause or exit if so
- (let* ((th2 (make-thread (lambda ()
- (debug:print-info 0 *default-log-port* "Server run thread started")
- (http-transport:run
- (if (args:get-arg "-server")
- (args:get-arg "-server")
- "-")
- )) "Server run"))
- (th3 (make-thread (lambda ()
- (debug:print-info 0 *default-log-port* "Server monitor thread started")
- (http-transport:keep-running)
- "Keep running"))))
- (thread-start! th2)
- (thread-sleep! 0.25) ;; give the server time to settle before starting the keep-running monitor.
- (thread-start! th3)
- (set! *didsomething* #t)
- (thread-join! th2)
- (exit)))
-
-;; (define (http-transport:server-signal-handler signum)
-;; (signal-mask! signum)
-;; (handle-exceptions
-;; exn
-;; (debug:print 0 *default-log-port* " ... exiting ...")
-;; (let ((th1 (make-thread (lambda ()
-;; (thread-sleep! 1))
-;; "eat response"))
-;; (th2 (make-thread (lambda ()
-;; (debug:print-error 0 *default-log-port* "Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.")
-;; (thread-sleep! 3) ;; give the flush three seconds to do it's stuff
-;; (debug:print 0 *default-log-port* " Done.")
-;; (exit 4))
-;; "exit on ^C timer")))
-;; (thread-start! th2)
-;; (thread-start! th1)
-;; (thread-join! th2))))
-
-;;===============================================
-;; Java script
-;;===============================================
-(define (http-transport:show-jquery)
- (let* ((data (tests:readlines *java-script-lib*)))
-(string-join data "\n")))
-
-
-
-;;======================================================================
-;; web pages
-;;======================================================================
-
-(define (http-transport:html-test-log $)
- (let* ((run-id ($ 'runid))
- (test-item ($ 'testname))
- (parts (string-split test-item ":"))
- (test-name (car parts))
-
- (item-name (if (equal? (length parts) 1)
- ""
- (cadr parts))))
- ;(print $)
-(tests:get-test-log run-id test-name item-name)))
-
-
-(define (http-transport:html-dboard $)
- (let* ((page ($ 'page))
- (oup (open-output-string))
- (bdy "--------------------------")
-
- (ret (tests:dynamic-dboard page)))
- (s:output-new oup ret)
- (close-output-port oup)
-
- (set! bdy (get-output-string oup))
- (conc "
Dashboard
" bdy "
" )))
-
-(define (http-transport:main-page)
- (let ((linkpath (root-path)))
- (conc "" (pathname-strip-directory *toppath*) "
"
- ""
- "Run area: " *toppath*
- "Server Stats
"
- (http-transport:stats-table)
- "
"
- (http-transport:runs linkpath)
- "
"
- ;; (http-transport:run-stats)
- ""
- )))
-
-(define (http-transport:stats-table)
- (mutex-lock! *heartbeat-mutex*)
- (let ((res
- (conc ""
- ;; "Max cached queries | " *max-cache-size* " |
"
- "Number of cached writes | " *number-of-writes* " |
"
- "Average cached write time | " (if (eq? *number-of-writes* 0)
- "n/a (no writes)"
- (/ *writes-total-delay*
- *number-of-writes*))
- " ms |
"
- "Number non-cached queries | " *number-non-write-queries* " |
"
- ;; "Average non-cached time | " (if (eq? *number-non-write-queries* 0)
- ;; "n/a (no queries)"
- ;; (/ *total-non-write-delay*
- ;; *number-non-write-queries*))
- " ms |
"
- "Last access | " (seconds->time-string *db-last-access*) " |
"
- "
")))
- (mutex-unlock! *heartbeat-mutex*)
- res))
-
-(define (http-transport:runs linkpath)
- (conc "Runs
"
- (string-intersperse
- (let ((files (map pathname-strip-directory (glob (conc linkpath "/*")))))
- (map (lambda (p)
- (conc "" p "
"))
- files))
- " ")))
-
-#;(define (http-transport:run-stats)
- (let ((stats (open-run-close db:get-running-stats #f)))
- (conc ""
- (string-intersperse
- (map (lambda (stat)
- (conc "" (car stat) " | " (cadr stat) " |
"))
- stats)
- " ")
- "
")))
+;;
+;; (declare (uses common))
+;; (declare (uses db))
+;; (declare (uses tests))
+;; (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
+;; (declare (uses server))
+;; ;; (declare (uses daemon))
+;; (declare (uses portlogger))
+;; (declare (uses rmt))
+;; (declare (uses dbfile))
+;; (declare (uses commonmod))
+;;
+;; (include "common_records.scm")
+;; (include "db_records.scm")
+;; (include "js-path.scm")
+;;
+;; (import dbfile commonmod)
+;;
+;; (require-library stml)
+;; (define (http-transport:make-server-url hostport)
+;; (if (not hostport)
+;; #f
+;; (conc "http://" (car hostport) ":" (cadr hostport))))
+;;
+;; (define *server-loop-heart-beat* (current-seconds))
+;;
+;; ;;======================================================================
+;; ;; S E R V E R
+;; ;; ======================================================================
+;;
+;; ;; Call this to start the actual server
+;; ;;
+;;
+;; (define *db:process-queue-mutex* (make-mutex))
+;;
+;; (define (http-transport:run hostn)
+;; ;; Configurations for server
+;; (tcp-buffer-size 2048)
+;; (max-connections 2048)
+;; (debug:print 2 *default-log-port* "Attempting to start the server ...")
+;; (let* ((db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily
+;; (hostname (get-host-name))
+;; (ipaddrstr (let ((ipstr (if (string=? "-" hostn)
+;; ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
+;; (server:get-best-guess-address hostname)
+;; #f)))
+;; (if ipstr ipstr hostn))) ;; hostname)))
+;; (start-port (portlogger:open-run-close portlogger:find-port))
+;; (link-tree-path (common:get-linktree))
+;; (tmp-area (common:get-db-tmp-area))
+;; (start-file (conc tmp-area "/.server-start")))
+;; (debug:print-info 0 *default-log-port* "portlogger recommended port: " start-port)
+;; ;; set some parameters for the server
+;; (root-path (if link-tree-path
+;; link-tree-path
+;; (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP!
+;; (handle-directory spiffy-directory-listing)
+;; (handle-exception (lambda (exn chain)
+;; (signal (make-composite-condition
+;; (make-property-condition
+;; 'server
+;; 'message "server error")))))
+;;
+;; ;; http-transport:handle-directory) ;; simple-directory-handler)
+;; ;; Setup the web server and a /ctrl interface
+;; ;;
+;; (vhost-map `(((* any) . ,(lambda (continue)
+;; ;; open the db on the first call
+;; ;; This is were we set up the database connections
+;; (let* (($ (request-vars source: 'both))
+;; (dat ($ 'dat))
+;; (res #f))
+;; (cond
+;; ((equal? (uri-path (request-uri (current-request)))
+;; '(/ "api"))
+;; (send-response body: (api:process-request *dbstruct-dbs* $) ;; the $ is the request vars proc
+;; headers: '((content-type text/plain)))
+;; (mutex-lock! *heartbeat-mutex*)
+;; (set! *db-last-access* (current-seconds))
+;; (mutex-unlock! *heartbeat-mutex*))
+;; ((equal? (uri-path (request-uri (current-request)))
+;; '(/ ""))
+;; (send-response body: (http-transport:main-page)))
+;; ((equal? (uri-path (request-uri (current-request)))
+;; '(/ "json_api"))
+;; (send-response body: (http-transport:main-page)))
+;; ((equal? (uri-path (request-uri (current-request)))
+;; '(/ "runs"))
+;; (send-response body: (http-transport:main-page)))
+;; ((equal? (uri-path (request-uri (current-request)))
+;; '(/ any))
+;; (send-response body: "hey there!\n"
+;; headers: '((content-type text/plain))))
+;; ((equal? (uri-path (request-uri (current-request)))
+;; '(/ "hey"))
+;; (send-response body: "hey there!\n"
+;; headers: '((content-type text/plain))))
+;; ((equal? (uri-path (request-uri (current-request)))
+;; '(/ "jquery3.1.0.js"))
+;; (send-response body: (http-transport:show-jquery)
+;; headers: '((content-type application/javascript))))
+;; ((equal? (uri-path (request-uri (current-request)))
+;; '(/ "test_log"))
+;; (send-response body: (http-transport:html-test-log $)
+;; headers: '((content-type text/HTML))))
+;; ((equal? (uri-path (request-uri (current-request)))
+;; '(/ "dashboard"))
+;; (send-response body: (http-transport:html-dboard $)
+;; headers: '((content-type text/HTML))))
+;; (else (continue))))))))
+;; (handle-exceptions
+;; exn
+;; (debug:print 0 *default-log-port* "Failed to create file " start-file ", exn=" exn)
+;; (with-output-to-file start-file (lambda ()(print (current-process-id)))))
+;; (http-transport:try-start-server ipaddrstr start-port)))
+;;
+;; ;; This is recursively run by http-transport:run until sucessful
+;; ;;
+;; (define (http-transport:try-start-server ipaddrstr portnum)
+;; (let ((config-hostname (configf:lookup *configdat* "server" "hostname"))
+;; (config-use-proxy (equal? (configf:lookup *configdat* "client" "use-http_proxy") "yes")))
+;; (if (not config-use-proxy)
+;; (determine-proxy (constantly #f)))
+;; (debug:print-info 0 *default-log-port* "http-transport:try-start-server time=" (seconds->time-string (current-seconds)) " ipaddrsstr=" ipaddrstr " portnum=" portnum " config-hostname=" config-hostname)
+;; (handle-exceptions
+;; exn
+;; (begin
+;; ;; (print-error-message exn)
+;; (if (< portnum 64000)
+;; (begin
+;; (debug:print 0 *default-log-port* "WARNING: attempt to start server failed. Trying again ...")
+;; (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+;; (debug:print 5 *default-log-port* "exn=" (condition->list exn))
+;; (portlogger:open-run-close portlogger:set-failed portnum)
+;; (debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port")
+;; (thread-sleep! 0.1)
+;;
+;; ;; get_next_port goes here
+;; (http-transport:try-start-server ipaddrstr
+;; (portlogger:open-run-close portlogger:find-port)))
+;; (begin
+;; (debug:print 0 *default-log-port* "ERROR: Tried and tried but could not start the server"))))
+;; ;; any error in following steps will result in a retry
+;; (set! *server-info* (list ipaddrstr portnum))
+;; (debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum)
+;; ;; This starts the spiffy server
+;; ;; NEED WAY TO SET IP TO #f TO BIND ALL
+;; ;; (start-server bind-address: ipaddrstr port: portnum)
+;; (if config-hostname ;; this is a hint to bind directly
+;; (start-server port: portnum) ;; bind-address: (if (equal? config-hostname "-")
+;; ;; ipaddrstr
+;; ;; config-hostname))
+;; (start-server port: portnum))
+;; (portlogger:open-run-close portlogger:set-port portnum "released")
+;; (debug:print 1 *default-log-port* "INFO: server has been stopped"))))
+;;
+;; ;;======================================================================
+;; ;; S E R V E R U T I L I T I E S
+;; ;;======================================================================
+;;
+;; ;;======================================================================
+;; ;; C L I E N T S
+;; ;;======================================================================
+;;
+;; (define *http-mutex* (make-mutex))
+;;
+;; ;; NOTE: Large block of code from 32436b426188080f72fceb6894af541fbad9921e removed here
+;; ;; I'm pretty sure it is defunct.
+;;
+;; ;; This next block all imported en-mass from the api branch
+;; (define *http-requests-in-progress* 0)
+;; (define *http-connections-next-cleanup* (current-seconds))
+;;
+;; (define (http-transport:get-time-to-cleanup)
+;; (let ((res #f))
+;; (mutex-lock! *http-mutex*)
+;; (set! res (> (current-seconds) *http-connections-next-cleanup*))
+;; (mutex-unlock! *http-mutex*)
+;; res))
+;;
+;; (define (http-transport:inc-requests-count)
+;; (mutex-lock! *http-mutex*)
+;; (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*))
+;; ;; Use this opportunity to slow things down iff there are too many requests in flight
+;; (if (> *http-requests-in-progress* 5)
+;; (begin
+;; (debug:print-info 0 *default-log-port* "Whoa there buddy, ease up...")
+;; (thread-sleep! 1)))
+;; (mutex-unlock! *http-mutex*))
+;;
+;; (define (http-transport:dec-requests-count proc)
+;; (mutex-lock! *http-mutex*)
+;; (proc)
+;; (set! *http-requests-in-progress* (- *http-requests-in-progress* 1))
+;; (mutex-unlock! *http-mutex*))
+;;
+;; (define (http-transport:dec-requests-count-and-close-all-connections)
+;; (set! *http-requests-in-progress* (- *http-requests-in-progress* 1))
+;; (let loop ((etime (+ (current-seconds) 5))) ;; give up in five seconds
+;; (if (> *http-requests-in-progress* 0)
+;; (if (> etime (current-seconds))
+;; (begin
+;; (thread-sleep! 0.05)
+;; (loop etime))
+;; (debug:print-error 0 *default-log-port* "requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections"))
+;; (close-all-connections!)))
+;; (set! *http-connections-next-cleanup* (+ (current-seconds) 10))
+;; (mutex-unlock! *http-mutex*))
+;;
+;; (define (http-transport:inc-requests-and-prep-to-close-all-connections)
+;; (mutex-lock! *http-mutex*)
+;; (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*)))
+;;
+;; ;; Send "cmd" with json payload "params" to serverdat and receive result
+;; ;;
+;; (define (http-transport:client-api-send-receive run-id runremote cmd params #!key (numretries 3))
+;; (assert (remote? runremote) "FATAL: http-transport:client-api-send-receive called with serverdat="serverdat)
+;; (let* ((fullurl (remote-api-req runremote))
+;; (res (vector #f "uninitialized"))
+;; (success #t)
+;; (sparams (db:obj->string params transport: 'http))
+;; (server-id (remote-server-id runremote)))
+;; (debug:print-info 11 *default-log-port* "cmd=" cmd " fullurl=" fullurl " server-id=" server-id " current time:" (current-seconds))
+;;
+;; ;; set up the http-client here
+;; (max-retry-attempts 1)
+;; ;; consider all requests indempotent
+;; (retry-request? (lambda (request)
+;; #f))
+;; ;; send the data and get the response
+;; ;; extract the needed info from the http data and
+;; ;; process and return it.
+;; (let* ((send-recieve (lambda ()
+;; (mutex-lock! *http-mutex*)
+;; ;; (condition-case (with-input-from-request "http://localhost"; #f read-lines)
+;; ;; ((exn http client-error) e (print e)))
+;; (set! res (vector ;;; DON'T FORGET - THIS IS THE CLIENT SIDE! NOTE: consider moving this to client.scm since we are only supporting http transport at this time.
+;; success
+;; (db:string->obj
+;; (handle-exceptions
+;; exn
+;; (let ((call-chain (get-call-chain))
+;; (msg ((condition-property-accessor 'exn 'message) exn)))
+;; (set! success #f)
+;; (if (debug:debug-mode 1)
+;; (debug:print-info 0 *default-log-port* "couldn't talk to server, trying again ...")
+;; (begin
+;; (debug:print 0 *default-log-port* "WARNING: failure in with-input-from-request to " fullurl ".")
+;; (debug:print 0 *default-log-port* " message: " msg ", exn=" exn)
+;; (debug:print 0 *default-log-port* " cmd: " cmd " params: " params " key:" (or server-id "thekey"))
+;; (debug:print 0 *default-log-port* " call-chain: " call-chain)))
+;; ;; what if another thread is communicating ok? Can't happen due to mutex
+;; (http-transport:close-connections runremote)
+;; (mutex-unlock! *http-mutex*)
+;; ;; (close-connection! fullurl)
+;; (db:obj->string #f))
+;; (with-input-from-request ;; was dat
+;; fullurl
+;; (list (cons 'key (or server-id "thekey"))
+;; (cons 'cmd cmd)
+;; (cons 'params sparams))
+;; read-string))
+;; transport: 'http)
+;; 0)) ;; added this speculatively
+;; ;; Shouldn't this be a call to the managed call-all-connections stuff above?
+;; ;; (close-all-connections!) ;; BUG? WHY IS THIS HERE? Are we failing to reuse connections?
+;; (mutex-unlock! *http-mutex*)
+;; ))
+;; (time-out (lambda ()
+;; (thread-sleep! 45)
+;; (debug:print 0 *default-log-port* "WARNING: send-receive took more than 45 seconds!!")
+;; #f))
+;; (th1 (make-thread send-recieve "with-input-from-request"))
+;; (th2 (make-thread time-out "time out")))
+;; (thread-start! th1)
+;; (thread-start! th2)
+;; (thread-join! th1)
+;; (vector-set! res 0 success)
+;; (thread-terminate! th2)
+;; (if (vector? res)
+;; (if (vector-ref res 0) ;; this is the first flag or the second flag?
+;; (let* ((res-dat (vector-ref res 1)))
+;; (if (and (string? res-dat) (string-contains res-dat "server-id mismatch"))
+;; (signal (make-composite-condition
+;; (make-property-condition
+;; 'servermismatch
+;; 'message (vector-ref res 1))))
+;; res)) ;; this is the *inner* vector? seriously? why?
+;; (if (debug:debug-mode 11)
+;; (let ((call-chain (get-call-chain))) ;; note: this code also called in nmsg-transport - consider consolidating it
+;; (print-call-chain (current-error-port))
+;; (debug:print-error 11 *default-log-port* "error above occured at server, res=" res) ;; " message: " ((condition-property-accessor 'exn 'message) exn))
+;; (debug:print 11 *default-log-port* " server call chain:")
+;; (pp (vector-ref res 1) (current-error-port))
+;; (signal (vector-ref res 0)))
+;; res))
+;; (signal (make-composite-condition
+;; (make-property-condition
+;; 'timeout
+;; 'message "nmsg-transport:client-api-send-receive-raw timed out talking to server")))))))
+;;
+;; ;; careful closing of connections stored in *runremote*
+;; ;;
+;; (define (http-transport:close-connections runremote)
+;; (if (remote? runremote)
+;; (let ((api-dat (remote-api-uri runremote)))
+;; (handle-exceptions
+;; exn
+;; (begin
+;; (print-call-chain *default-log-port*)
+;; (debug:print-error 0 *default-log-port* " closing connection failed with error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn))
+;; (if (args:any-defined? "-server" "-execute" "-run")
+;; (debug:print-info 0 *default-log-port* "Closing connections to "api-dat))
+;; (if api-dat (close-connection! api-dat))
+;; (remote-conndat-set! runremote #f)
+;; #t))
+;; #f))
+;;
+;; ;; run http-transport:keep-running in a parallel thread to monitor that the db is being
+;; ;; used and to shutdown after sometime if it is not.
+;; ;;
+;; (define (http-transport:keep-running)
+;; ;; if none running or if > 20 seconds since
+;; ;; server last used then start shutdown
+;; ;; This thread waits for the server to come alive
+;; (debug:print-info 0 *default-log-port* "Starting the sync-back, keep alive thread in server")
+;; (let* ((servinfofile #f)
+;; (sdat #f)
+;; (no-sync-db (db:open-no-sync-db))
+;; (tmp-area (common:get-db-tmp-area))
+;; (started-file (conc tmp-area "/.server-started"))
+;; (server-start-time (current-seconds))
+;; (server-info (let loop ((start-time (current-seconds))
+;; (changed #t)
+;; (last-sdat "not this"))
+;; (begin ;; let ((sdat #f))
+;; (thread-sleep! 0.01)
+;; (debug:print-info 0 *default-log-port* "Waiting for server alive signature")
+;; (mutex-lock! *heartbeat-mutex*)
+;; (set! sdat *server-info*)
+;; (mutex-unlock! *heartbeat-mutex*)
+;; (if (and sdat
+;; (not changed)
+;; (> (- (current-seconds) start-time) 2))
+;; (let* ((servinfodir (server:get-servinfo-dir *toppath*)) ;; (conc *toppath*"/.servinfo"))
+;; (ipaddr (car sdat))
+;; (port (cadr sdat))
+;; (servinf (conc servinfodir"/"ipaddr":"port)))
+;; (set! servinfofile servinf)
+;; (if (not (file-exists? servinfodir))
+;; (create-directory servinfodir #t))
+;; (with-output-to-file servinf
+;; (lambda ()
+;; (let* ((serv-id (server:mk-signature)))
+;; (set! *server-id* serv-id)
+;; (print "SERVER STARTED: "ipaddr":"port" AT "(current-seconds)" server-id: "serv-id" pid: "(current-process-id))
+;; (print "started: "(seconds->year-week/day-time (current-seconds))))))
+;; (set! *on-exit-procs* (cons
+;; (lambda ()
+;; (delete-file* servinf))
+;; *on-exit-procs*))
+;; ;; put data about this server into a simple flat file host.port
+;; (debug:print-info 0 *default-log-port* "Received server alive signature")
+;; sdat)
+;; (begin
+;; (debug:print-info 0 *default-log-port* "Still waiting, last-sdat=" last-sdat)
+;; (sleep 4)
+;; (if (> (- (current-seconds) start-time) 120) ;; been waiting for two minutes
+;; (if sdat
+;; (let* ((ipaddr (car sdat))
+;; (port (cadr sdat))
+;; (servinf (conc (server:get-servinfo-dir *toppath*)"/"ipaddr":"port)))
+;; (debug:print-error 0 *default-log-port* "transport appears to have died, exiting server")
+;; (exit))
+;; (exit)
+;; )
+;; (loop start-time
+;; (equal? sdat last-sdat)
+;; sdat)))))))
+;; (iface (car server-info))
+;; (port (cadr server-info))
+;; (last-access 0)
+;; (server-timeout (server:expiration-timeout))
+;; (server-going #f)
+;; (server-log-file (args:get-arg "-log"))) ;; always set when we are a server
+;;
+;; (handle-exceptions
+;; exn
+;; (debug:print 0 *default-log-port* "Failed to create " started-file ", exn=" exn)
+;; (with-output-to-file started-file (lambda ()(print (current-process-id)))))
+;;
+;; (let loop ((count 0)
+;; (server-state 'available)
+;; (bad-sync-count 0)
+;; (start-time (current-milliseconds)))
+;;
+;; ;; Use this opportunity to sync the tmp db to megatest.db
+;; (if (not server-going) ;; *dbstruct-dbs*
+;; (begin
+;; (debug:print 0 *default-log-port* "SERVER: dbprep")
+;; (set! *dbstruct-dbs* (db:setup #t)) ;; run-id)) FIXME!!!
+;; (set! server-going #t)
+;; (debug:print 0 *default-log-port* "SERVER: running, megatest version: " (common:get-full-version))) ;; NOTE: the server is NOT yet marked as running in the log. We do that in the keep-running routine.
+;; (if (and no-sync-db
+;; (common:low-noise-print 10 "sync-all")) ;; cheesy way to reduce frequency of running sync :)
+;; (begin
+;; (if (common:low-noise-print 120 "sync-all-print")
+;; (debug:print 0 *default-log-port* "keep-running calling db:all-db-sync at " (time->string (seconds->local-time) "%H:%M:%S")))
+;; (db:all-db-sync *dbstruct-dbs*)
+;; )))
+;;
+;; ;; when things go wrong we don't want to be doing the various queries too often
+;; ;; so we strive to run this stuff only every four seconds or so.
+;; (let* ((sync-time (- (current-milliseconds) start-time))
+;; (rem-time (quotient (- 4000 sync-time) 1000)))
+;; (if (and (<= rem-time 4)
+;; (> rem-time 0))
+;; (thread-sleep! rem-time)))
+;;
+;; (if (< count 1) ;; 3x3 = 9 secs aprox
+;; (loop (+ count 1) 'running bad-sync-count (current-milliseconds)))
+;;
+;; ;; Check that iface and port have not changed (can happen if server port collides)
+;; (mutex-lock! *heartbeat-mutex*)
+;; (set! sdat *server-info*)
+;; (mutex-unlock! *heartbeat-mutex*)
+;;
+;; (if (not (equal? sdat (list iface port)))
+;; (let ((new-iface (car sdat))
+;; (new-port (cadr sdat)))
+;; (debug:print-info 0 *default-log-port* "WARNING: interface changed, refreshing iface and port info")
+;; (set! iface new-iface)
+;; (set! port new-port)
+;; (if (not *server-id*)
+;; (set! *server-id* (server:mk-signature)))
+;; (debug:print 0 *default-log-port* "SERVER STARTED: " iface ":" port " AT " (current-seconds) " server-id: " *server-id*)
+;; (flush-output *default-log-port*)))
+;;
+;; ;; Transfer *db-last-access* to last-access to use in checking that we are still alive
+;; (mutex-lock! *heartbeat-mutex*)
+;; (set! last-access *db-last-access*)
+;; (mutex-unlock! *heartbeat-mutex*)
+;;
+;; (if (common:low-noise-print 120 (conc "server running on " iface ":" port))
+;; (begin
+;; (if (not *server-id*)
+;; (set! *server-id* (server:mk-signature)))
+;; (debug:print 0 *default-log-port* (current-seconds) (current-directory) (current-process-id) (argv))
+;; (debug:print 0 *default-log-port* "SERVER STARTED: " iface ":" port " AT " (current-seconds) " server-id: " *server-id*)
+;; (flush-output *default-log-port*)))
+;; (if (common:low-noise-print 60 "dbstats")
+;; (begin
+;; (debug:print 0 *default-log-port* "Server stats:")
+;; (db:print-current-query-stats)))
+;; (let* ((hrs-since-start (/ (- (current-seconds) server-start-time) 3600)))
+;; (cond
+;; ((and *server-run*
+;; (> (+ last-access server-timeout)
+;; (current-seconds)))
+;; (if (common:low-noise-print 120 "server continuing")
+;; (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
+;; (let ((curr-time (current-seconds)))
+;; (handle-exceptions
+;; exn
+;; (debug:print 0 *default-log-port* "ERROR: Failed to change timestamp on info file " servinfofile ". Are you out of space on that disk? exn=" exn)
+;; (if (and ;; (< (- (current-seconds) server-start-time) 600) ;; run for ten minutes for experiment, 3600 thereafter
+;; (not *server-overloaded*)
+;; (file-exists? servinfofile))
+;; (change-file-times servinfofile curr-time curr-time)))
+;; (if (and (common:low-noise-print 120 "start new server")
+;; (> *api-process-request-count* 50)) ;; if this server is kind of busy start up another
+;; (begin
+;; (debug:print-info 0 *default-log-port* "Server is busy, api-count "*api-process-request-count*", start another if possible...")
+;; (server:kind-run *toppath*)
+;; (if (> *api-process-request-count* 100)
+;; (begin
+;; (debug:print-info 0 *default-log-port* "Server is overloaded at api-count=" *api-process-request-count*", removing "servinfofile)
+;; (delete-file* servinfofile)))))))
+;; (loop 0 server-state bad-sync-count (current-milliseconds)))
+;; (else
+;; (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access))
+;; (http-transport:server-shutdown port)))))))
+;;
+;; (define (http-transport:server-shutdown port)
+;; (begin
+;; ;;(BB> "http-transport:server-shutdown called")
+;; (debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id))
+;; ;;
+;; ;; start_shutdown
+;; ;;
+;; (set! *time-to-exit* #t) ;; tell on-exit to be fast as we've already cleaned up
+;; (portlogger:open-run-close portlogger:set-port port "released")
+;; (thread-sleep! 1)
+;;
+;; ;; (debug:print-info 0 *default-log-port* "Max cached queries was " *max-cache-size*)
+;; ;; (debug:print-info 0 *default-log-port* "Number of cached writes " *number-of-writes*)
+;; ;; (debug:print-info 0 *default-log-port* "Average cached write time "
+;; ;; (if (eq? *number-of-writes* 0)
+;; ;; "n/a (no writes)"
+;; ;; (/ *writes-total-delay*
+;; ;; *number-of-writes*))
+;; ;; " ms")
+;; ;; (debug:print-info 0 *default-log-port* "Number non-cached queries " *number-non-write-queries*)
+;; ;; (debug:print-info 0 *default-log-port* "Average non-cached time "
+;; ;; (if (eq? *number-non-write-queries* 0)
+;; ;; "n/a (no queries)"
+;; ;; (/ *total-non-write-delay*
+;; ;; *number-non-write-queries*))
+;; ;; " ms")
+;;
+;; (db:print-current-query-stats)
+;; #;(common:save-pkt `((action . exit)
+;; (T . server)
+;; (pid . ,(current-process-id)))
+;; *configdat* #t)
+;;
+;; ;; remove .servinfo file(s) here
+;;
+;; (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
+;; (exit)))
+;;
+;; ;; all routes though here end in exit ...
+;; ;;
+;; ;; start_server?
+;; ;;
+;; (define (http-transport:launch)
+;; ;; check the .servinfo directory, are there other servers running on this
+;; ;; or another host?
+;; (let* ((server-start-is-ok (server:minimal-check *toppath*)))
+;; (if (not server-start-is-ok)
+;; (begin
+;; (debug:print 0 *default-log-port* "ERROR: server start not ok, exiting now.")
+;; (exit 1))))
+;;
+;; ;; check that a server start is in progress, pause or exit if so
+;; (let* ((th2 (make-thread (lambda ()
+;; (debug:print-info 0 *default-log-port* "Server run thread started")
+;; (http-transport:run
+;; (if (args:get-arg "-server")
+;; (args:get-arg "-server")
+;; "-")
+;; )) "Server run"))
+;; (th3 (make-thread (lambda ()
+;; (debug:print-info 0 *default-log-port* "Server monitor thread started")
+;; (http-transport:keep-running)
+;; "Keep running"))))
+;; (thread-start! th2)
+;; (thread-sleep! 0.25) ;; give the server time to settle before starting the keep-running monitor.
+;; (thread-start! th3)
+;; (set! *didsomething* #t)
+;; (thread-join! th2)
+;; (exit)))
+;;
+;; ;; (define (http-transport:server-signal-handler signum)
+;; ;; (signal-mask! signum)
+;; ;; (handle-exceptions
+;; ;; exn
+;; ;; (debug:print 0 *default-log-port* " ... exiting ...")
+;; ;; (let ((th1 (make-thread (lambda ()
+;; ;; (thread-sleep! 1))
+;; ;; "eat response"))
+;; ;; (th2 (make-thread (lambda ()
+;; ;; (debug:print-error 0 *default-log-port* "Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.")
+;; ;; (thread-sleep! 3) ;; give the flush three seconds to do it's stuff
+;; ;; (debug:print 0 *default-log-port* " Done.")
+;; ;; (exit 4))
+;; ;; "exit on ^C timer")))
+;; ;; (thread-start! th2)
+;; ;; (thread-start! th1)
+;; ;; (thread-join! th2))))
+;;
+;; ;;===============================================
+;; ;; Java script
+;; ;;===============================================
+;; (define (http-transport:show-jquery)
+;; (let* ((data (tests:readlines *java-script-lib*)))
+;; (string-join data "\n")))
+;;
+;;
+;;
+;; ;;======================================================================
+;; ;; web pages
+;; ;;======================================================================
+;;
+;; (define (http-transport:html-test-log $)
+;; (let* ((run-id ($ 'runid))
+;; (test-item ($ 'testname))
+;; (parts (string-split test-item ":"))
+;; (test-name (car parts))
+;;
+;; (item-name (if (equal? (length parts) 1)
+;; ""
+;; (cadr parts))))
+;; ;(print $)
+;; (tests:get-test-log run-id test-name item-name)))
+;;
+;;
+;; (define (http-transport:html-dboard $)
+;; (let* ((page ($ 'page))
+;; (oup (open-output-string))
+;; (bdy "--------------------------")
+;;
+;; (ret (tests:dynamic-dboard page)))
+;; (s:output-new oup ret)
+;; (close-output-port oup)
+;;
+;; (set! bdy (get-output-string oup))
+;; (conc "Dashboard
" bdy "
" )))
+;;
+;; (define (http-transport:main-page)
+;; (let ((linkpath (root-path)))
+;; (conc "" (pathname-strip-directory *toppath*) "
"
+;; ""
+;; "Run area: " *toppath*
+;; "Server Stats
"
+;; (http-transport:stats-table)
+;; "
"
+;; (http-transport:runs linkpath)
+;; "
"
+;; ;; (http-transport:run-stats)
+;; ""
+;; )))
+;;
+;; (define (http-transport:stats-table)
+;; (mutex-lock! *heartbeat-mutex*)
+;; (let ((res
+;; (conc ""
+;; ;; "Max cached queries | " *max-cache-size* " |
"
+;; "Number of cached writes | " *number-of-writes* " |
"
+;; "Average cached write time | " (if (eq? *number-of-writes* 0)
+;; "n/a (no writes)"
+;; (/ *writes-total-delay*
+;; *number-of-writes*))
+;; " ms |
"
+;; "Number non-cached queries | " *number-non-write-queries* " |
"
+;; ;; "Average non-cached time | " (if (eq? *number-non-write-queries* 0)
+;; ;; "n/a (no queries)"
+;; ;; (/ *total-non-write-delay*
+;; ;; *number-non-write-queries*))
+;; " ms |
"
+;; "Last access | " (seconds->time-string *db-last-access*) " |
"
+;; "
")))
+;; (mutex-unlock! *heartbeat-mutex*)
+;; res))
+;;
+;; (define (http-transport:runs linkpath)
+;; (conc "Runs
"
+;; (string-intersperse
+;; (let ((files (map pathname-strip-directory (glob (conc linkpath "/*")))))
+;; (map (lambda (p)
+;; (conc "" p "
"))
+;; files))
+;; " ")))
+;;
+;; #;(define (http-transport:run-stats)
+;; (let ((stats (open-run-close db:get-running-stats #f)))
+;; (conc ""
+;; (string-intersperse
+;; (map (lambda (stat)
+;; (conc "" (car stat) " | " (cadr stat) " |
"))
+;; stats)
+;; " ")
+;; "
")))
+;;
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -25,12 +25,10 @@
(declare (uses common))
;; (declare (uses megatest-version))
(declare (uses margs))
(declare (uses runs))
(declare (uses launch))
-(declare (uses server))
-(declare (uses client))
(declare (uses tests))
(declare (uses genexample))
;; (declare (uses daemon))
(declare (uses db))
@@ -43,10 +41,13 @@
(declare (uses env))
(declare (uses diff-report))
(declare (uses db))
(declare (uses dbmod))
(declare (uses dbmod.import))
+(declare (uses rmtmod))
+(declare (uses clientmod))
+(declare (uses servermod))
(declare (uses commonmod))
(declare (uses commonmod.import))
(declare (uses dbfile))
(declare (uses dbfile.import))
;; (declare (uses debugprint))
Index: mt.scm
==================================================================
--- mt.scm
+++ mt.scm
@@ -24,13 +24,13 @@
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
-(declare (uses server))
+(declare (uses servermod))
(declare (uses runs))
-(declare (uses rmt))
+(declare (uses rmtmod))
;; (declare (uses filedb))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
Index: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -22,1056 +22,1058 @@
(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
-;;
-;; grep define ../rmt.scm | grep rmt: |perl -pi -e 's/\(define\s+\((\S+)\W.*$/\1/'|sort -u
-
-;;======================================================================
-;; S U P P O R T F U N C T I O N S
-;;======================================================================
-
-;; if a server is either running or in the process of starting call client:setup
-;; else return #f to let the calling proc know that there is no server available
-;;
-(define (rmt:get-connection-info areapath runremote) ;; TODO: push areapath down.
- (let* ((cinfo (if (remote? runremote)
- (remote-conndat runremote)
- #f)))
- (if cinfo
- cinfo
- (if (server:check-if-running areapath)
- (client:setup areapath runremote)
- #f))))
-
-(define (rmt:on-homehost? runremote)
- (let* ((hh-dat (remote-hh-dat runremote)))
- (if (pair? hh-dat)
- (cdr hh-dat)
- (begin
- (debug:print-info 0 *default-log-port* "hh-dat="hh-dat)
- #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
-
- #;(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)))
- (if (and (> attemptnum 5) (= 0 (modulo attemptnum 15)))
- (begin (server:run *toppath*) (thread-sleep! 3)))
-
-
- ;;DOT digraph megatest_state_status {
- ;;DOT ranksep=0;
- ;;DOT // rankdir=LR;
- ;;DOT node [shape="box"];
- ;;DOT "rmt:send-receive" -> MUTEXLOCK;
- ;;DOT { edge [style=invis];"case 1" -> "case 2" -> "case 3" -> "case 4" -> "case 5" -> "case 6" -> "case 7" -> "case 8" -> "case 9" -> "case 10" -> "case 11"; }
- ;; do all the prep locked under the rmt-mutex
- (mutex-lock! *rmt-mutex*)
-
- ;; 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*)))
-
- ;; DOT INIT_RUNREMOTE; // leaving off - doesn't really add to the clarity
- ;; DOT MUTEXLOCK -> INIT_RUNREMOTE [label="no remote?"];
- ;; DOT INIT_RUNREMOTE -> MUTEXLOCK;
- ;; ensure we have a record for our connection for given area
- (if (not runremote) ;; can remove this one. should never get here.
- (begin
- (set! *runremote* (make-remote))
- (let* ((server-info (remote-server-info *runremote*)))
- (if server-info
- (begin
- (remote-server-url-set! *runremote* (server:record->url server-info))
- (remote-server-id-set! *runremote* (server:record->id server-info)))))
- (set! runremote *runremote*))) ;; new runremote will come from this on next iteration
-
- ;; DOT SET_HOMEHOST; // leaving off - doesn't really add to the clarity
- ;; DOT MUTEXLOCK -> SET_HOMEHOST [label="no homehost?"];
- ;; DOT SET_HOMEHOST -> MUTEXLOCK;
- ;; 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
- (let ((hh-data (server:choose-server areapath 'homehost)))
- (remote-hh-dat-set! runremote (or hh-data (cons #f #f)))))
-
- ;;(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))
-
- ;;DOT CASE2 [label="local\nreadonly\nquery"];
- ;;DOT MUTEXLOCK -> CASE2; {rank=same "case 2" CASE2}
- ;;DOT CASE2 -> "rmt:open-qry-close-locally";
- ;; readonly mode, read request- handle it - case 2
- ((and readonly-mode
- (member cmd api:read-only-queries))
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 2")
- (rmt:open-qry-close-locally cmd 0 params)
- )
-
- ;;DOT CASE3 [label="write in\nread-only mode"];
- ;;DOT MUTEXLOCK -> CASE3 [label="readonly\nmode?"]; {rank=same "case 3" CASE3}
- ;;DOT CASE3 -> "#f";
- ;; readonly mode, write request. Do nothing, return #f
- (readonly-mode (extras-readonly-mode *rmt-mutex* *default-log-port* cmd params))
-
- ;; This block was for pre-emptively resetting the connection if there had been no communication for some time.
- ;; I don't think it adds any value. If the server is not there, just fail and start a new connection.
- ;; also, the expire-time calculation might not be correct. We want, time-since-last-server-access > (server:get-timeout)
- ;;
- ;;DOT CASE4 [label="reset\nconnection"];
- ;;DOT MUTEXLOCK -> CASE4 [label="have connection,\nlast_access > expire_time"]; {rank=same "case 4" CASE4}
- ;;DOT CASE4 -> "rmt:send-receive";
- ;; reset the connection if it has been unused too long
- ((and runremote
- ;; (remote-conndat runremote)
- (> (current-seconds) ;; if it has been more than server-timeout seconds since last contact, close this connection and start a new on
- (+ (remote-last-access runremote)
- (remote-server-timeout runremote))))
- (debug:print-info 0 *default-log-port* "Connection to " (remote-server-url runremote) " expired due to no accesses, forcing new connection.")
- (http-transport:close-connections runremote)
- ;; moving this setting of runremote conndat to #f to inside the http-transport:close-connections
- ;; (remote-conndat-set! runremote #f) ;; invalidate the connection, thus forcing a new connection.
- (mutex-unlock! *rmt-mutex*)
- (rmt:send-receive cmd rid params attemptnum: attemptnum))
-
- ;;DOT CASE5 [label="local\nread"];
- ;;DOT MUTEXLOCK -> CASE5 [label="server not required,\non homehost,\nread-only query"]; {rank=same "case 5" CASE5};
- ;;DOT CASE5 -> "rmt:open-qry-close-locally";
-
- ;; on homehost and this is a read
- ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
- (rmt:on-homehost? runremote)
- (member cmd api:read-only-queries)) ;; this is a read
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5")
- (rmt:open-qry-close-locally cmd 0 params))
-
- ;;DOT CASE6 [label="init\nremote"];
- ;;DOT MUTEXLOCK -> CASE6 [label="on homehost,\nwrite query,\nhave server,\ncan't reach it"]; {rank=same "case 6" CASE6};
- ;;DOT CASE6 -> "rmt:send-receive";
- ;; on homehost and this is a write, we already have a server, but server has died
-
- ;; reinstate this keep-alive section but inject a time condition into the (add ...
- ;;
- ;; ((and (cdr (remote-hh-dat runremote)) ;; on homehost
- ;; (not (member cmd api:read-only-queries)) ;; this is a write
- ;; (remote-server-url runremote) ;; have a server
- ;; (not (server:ping (remote-server-url runremote) (remote-server-id runremote)))) ;; server has died. NOTE: this is not a cheap call! Need better approach.
- ;; (debug:print 0 *default-log-port* "WARNING: server appears to have died, trying to reconnect, case 6")
- ;; (http-transport:close-connections area-dat: runremote) ;; make sure to clean up
- ;; (set! *runremote* (make-remote))
- ;; (let* ((server-info (remote-server-info *runremote*)))
- ;; (if server-info
- ;; (begin
- ;; (remote-server-url-set! *runremote* (server:record->url server-info))
- ;; (remote-server-id-set! *runremote* (server:record->id server-info)))))
- ;; (remote-force-server-set! runremote (common:force-server?))
- ;; (mutex-unlock! *rmt-mutex*)
- ;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 6")
- ;; (rmt:send-receive cmd rid params attemptnum: attemptnum))
-
- ;;DOT CASE7 [label="homehost\nwrite"];
- ;;DOT MUTEXLOCK -> CASE7 [label="server not required,\non homehost,\na write,\nhave a server"]; {rank=same "case 7" CASE7};
- ;;DOT CASE7 -> "rmt:open-qry-close-locally";
- ;; on homehost and this is a write, we already have a server
- ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
- (cdr (remote-hh-dat runremote)) ;; on homehost
- (not (member cmd api:read-only-queries)) ;; this is a write
- (remote-server-url runremote)) ;; have a server
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 4.1")
- (rmt:open-qry-close-locally cmd 0 params))
-
- ;;DOT CASE8 [label="force\nserver"];
- ;;DOT MUTEXLOCK -> CASE8 [label="server not required,\nhave homehost info,\nno connection yet,\nnot a read-only query"]; {rank=same "case 8" CASE8};
- ;;DOT CASE8 -> "rmt:open-qry-close-locally";
- ;; on homehost, no server contact made and this is a write, passively start a server
- ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
- (cdr (remote-hh-dat runremote)) ;; have homehost
- (not (remote-server-url runremote)) ;; no connection yet
- (not (member cmd api:read-only-queries))) ;; not a read-only query
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 8")
- (let ((server-info (server:check-if-running *toppath*))) ;; (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call
- (if server-info
- (begin
- (remote-server-url-set! runremote (server:record->url server-info)) ;; the string can be consumed by the client setup if needed
- (remote-server-id-set! runremote (server:record->id server-info)))
- (if (common:force-server?)
- (server:start-and-wait *toppath*)
- (server:kind-run *toppath*)))
- (remote-force-server-set! runremote (common:force-server?))
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 8.1")
- (rmt:open-qry-close-locally cmd 0 params)))
-
- ;;DOT CASE9 [label="force server\nnot on homehost"];
- ;;DOT MUTEXLOCK -> CASE9 [label="no connection\nand either require server\nor not on homehost"]; {rank=same "case 9" CASE9};
- ;;DOT CASE9 -> "start\nserver" -> "rmt:send-receive";
- ((or (and (remote-force-server runremote) ;; we are forcing a server and don't yet have a connection to one
- (not (remote-conndat runremote)))
- (and (not (cdr (remote-hh-dat runremote))) ;; not on a homehost
- (not (remote-conndat runremote)))) ;; and no connection
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9, hh-dat: " (remote-hh-dat runremote) " conndat: " (remote-conndat runremote))
- (mutex-unlock! *rmt-mutex*)
- (if (not (server:check-if-running *toppath*)) ;; who knows, maybe one has started up?
- (server:start-and-wait *toppath*))
- (remote-conndat-set! runremote (rmt:get-connection-info *toppath* runremote)) ;; calls client:setup which calls client:setup-http
- (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;; TODO: add back-off timeout as
-
- ;;DOT CASE10 [label="on homehost"];
- ;;DOT MUTEXLOCK -> CASE10 [label="server not required,\non homehost"]; {rank=same "case 10" CASE10};
- ;;DOT CASE10 -> "rmt:open-qry-close-locally";
- ;; all set up if get this far, dispatch the query
- ((and (not (remote-force-server runremote))
- (cdr (remote-hh-dat runremote))) ;; we are on homehost
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 10")
- (rmt:open-qry-close-locally cmd (if rid rid 0) params))
-
- ;;DOT CASE11 [label="send_receive"];
- ;;DOT MUTEXLOCK -> CASE11 [label="else"]; {rank=same "case 11" CASE11};
- ;;DOT CASE11 -> "rmt:send-receive" [label="call failed"];
- ;;DOT CASE11 -> "RESULT" [label="call succeeded"];
- ;; not on homehost, do server query
- (else (extras-case-11 *default-log-port* runremote cmd params attemptnum rid)))))
- ;;DOT }
-
-;; bunch of small functions factored out of send-receive to make debug easier
-;;
-
-(define (extras-case-11 *default-log-port* runremote cmd params attemptnum rid)
- ;; (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9")
- ;; (mutex-lock! *rmt-mutex*)
- (let* ((conninfo (remote-conndat runremote))
- (dat-in (condition-case ;; handling here has
- ;; caused a lot of
- ;; problems. However it
- ;; is needed to deal with
- ;; attemtped
- ;; communication to
- ;; servers that have gone
- ;; away
- (http-transport:client-api-send-receive 0 runremote cmd params)
- ;; (http-transport:client-api-send-receive 0 conninfo cmd params runremote)
- ((servermismatch) (vector #f "Server id mismatch" ))
- ((commfail)(vector #f "communications fail"))
- ((exn)(vector #f "other fail" (print-call-chain)))))
- (dat (if (and (vector? dat-in) ;; ... check it is a correct size
- (> (vector-length dat-in) 1))
- dat-in
- (vector #f (conc "communications fail (type 2), dat-in=" dat-in))))
- (success (if (vector? dat) (vector-ref dat 0) #f))
- (res (if (vector? dat) (vector-ref dat 1) #f)))
- (if (and (vector? conninfo) (< 5 (vector-length conninfo)))
- (remote-last-access-set! runremote (current-seconds)) ;; refresh access time
- (begin
- (debug:print 0 *default-log-port* "INFO: Should not get here! conninfo=" conninfo)
- (set! conninfo #f)
- (http-transport:close-connections runremote)))
- (debug:print-info 13 *default-log-port* "rmt:send-receive, case 9. conninfo=" conninfo " dat=" dat " runremote = " runremote)
- (mutex-unlock! *rmt-mutex*)
- (if success ;; success only tells us that the transport was
- ;; successful, have to examine the data to see if
- ;; there was a detected issue at the other end
- (extras-transport-succeded *default-log-port* *rmt-mutex* attemptnum runremote res params rid cmd)
- (begin
- (debug:print-error 0 *default-log-port* " dat=" dat)
- (extras-transport-failed *default-log-port* *rmt-mutex* attemptnum runremote cmd rid params))
- )))
-
-(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)
- (let loop ((cmd (car cmds))
- (tal (cdr cmds))
- (max-cmd (car cmds))
- (res 0))
- (let* ((cmd-dat (hash-table-ref *db-stats* cmd))
- (tot (vector-ref cmd-dat 0))
- (curravg (/ (vector-ref cmd-dat 1) (vector-ref cmd-dat 0))) ;; count is never zero by construction
- (currmax (max res curravg))
- (newmax-cmd (if (> curravg res) cmd max-cmd)))
- (if (null? tal)
- (if (> tot 10)
- (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)
- (begin
- (debug:print-error 0 *default-log-port* "local query failed. Trying again.")
- (thread-sleep! (/ (random 5000) 1000)) ;; some random delay
- (rmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1)))
- (begin
- (debug:print-error 0 *default-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! *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 runremote cmd run-id params)
- (let* ((run-id (if run-id run-id 0))
- (res (http-transport:client-api-send-receive run-id runremote 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
-;;
-;;======================================================================
-
-;;======================================================================
-;; 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))))
-
-;; hand off a call to one of the db:queries statements
-;; added run-id to make looking up the correct db possible
-;;
-(define (rmt:general-call stmtname run-id . params)
- (rmt:send-receive 'general-call run-id (append (list stmtname run-id) params)))
-
-
-;; 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)
- (rmt:send-receive 'runtests run-id testpatt))
-
-(define (rmt:get-run-record-ids target run keynames test-patt)
- (rmt:send-receive 'get-run-record-ids #f (list target run keynames test-patt)))
-
-(define (rmt:get-changed-record-ids since-time)
- (rmt:send-receive 'get-changed-record-ids #f (list since-time)) )
-
-(define (rmt:drop-all-triggers)
- (rmt:send-receive 'drop-all-triggers #f '()))
-
-(define (rmt:create-all-triggers)
- (rmt:send-receive 'create-all-triggers #f '()))
-
-;;======================================================================
-;; T E S T M E T A
-;;======================================================================
-
-(define (rmt:get-tests-tags)
- (rmt:send-receive 'get-tests-tags #f '()))
-
-;;======================================================================
-;; K E Y S
-;;======================================================================
-
-;; These require run-id because the values come from the run!
-;;
-(define (rmt:get-key-val-pairs run-id)
- (rmt:send-receive 'get-key-val-pairs run-id (list run-id)))
-
-(define (rmt:get-keys)
- (if *db-keys* *db-keys*
- (let ((res (rmt:send-receive 'get-keys #f '())))
- (set! *db-keys* res)
- res)))
-
-(define (rmt:get-keys-write) ;; dummy query to force server start
- (let ((res (rmt:send-receive 'get-keys-write #f '())))
- (set! *db-keys* res)
- res))
-
-;; we don't reuse run-id's (except possibly *after* a db cleanup) so it is safe
-;; to cache the resuls in a hash
-;;
-(define (rmt:get-key-vals run-id)
- (or (hash-table-ref/default *keyvals* run-id #f)
- (let ((res (rmt:send-receive 'get-key-vals #f (list run-id))))
- (hash-table-set! *keyvals* run-id res)
- res)))
-
-(define (rmt:get-targets)
- (rmt:send-receive 'get-targets #f '()))
-
-(define (rmt:get-target run-id)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'get-target run-id (list run-id)))
-
-(define (rmt:get-run-times runpatt targetpatt)
- (rmt:send-receive 'get-run-times #f (list runpatt targetpatt )))
-
-
-;;======================================================================
-;; T E S T S
-;;======================================================================
-
-;; Just some syntatic sugar
-(define (rmt:register-test run-id test-name item-path)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:general-call 'register-test run-id run-id test-name item-path))
-
-(define (rmt:get-test-id run-id testname item-path)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'get-test-id run-id (list run-id testname item-path)))
-
-;; run-id is NOT used
-;;
-(define (rmt:get-test-info-by-id run-id test-id)
- (if (number? test-id)
- (rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id))
- (begin
- (debug:print 0 *default-log-port* "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id)
- (print-call-chain (current-error-port))
- #f)))
-
-(define (rmt:test-get-rundir-from-test-id run-id test-id)
- (rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id)))
-
-(define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f))
- (assert (number? run-id) "FATAL: Run id required.")
- (let* ((test-path (if (string? work-area)
- work-area
- (rmt:test-get-rundir-from-test-id run-id test-id))))
- (debug:print 3 *default-log-port* "TEST PATH: " test-path)
- (open-test-db test-path)))
-
-;; WARNING: This currently bypasses the transaction wrapped writes system
-(define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment)))
-
-(define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'set-tests-state-status run-id (list run-id testnames currstate currstatus newstate newstatus)))
-
-(define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)
- (assert (number? run-id) "FATAL: Run id required.")
- ;; (if (number? run-id)
- (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)))
- ;; (begin
- ;; (debug:print-error 0 *default-log-port* "rmt:get-tests-for-run called with bad run-id=" run-id)
- ;; (print-call-chain (current-error-port))
- ;; '())))
-
-(define (rmt:get-tests-for-run-state-status run-id testpatt last-update)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'get-tests-for-run-state-status run-id (list run-id testpatt last-update)))
-
-;; get stuff via synchash
-(define (rmt:synchash-get run-id proc synckey keynum params)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'synchash-get run-id (list run-id proc synckey keynum params)))
-
-(define (rmt:get-tests-for-run-mindata run-id testpatt states status not-in)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-id testpatt states status not-in)))
-
-;; IDEA: Threadify these - they spend a lot of time waiting ...
-;;
-(define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in)
- (let ((multi-run-mutex (make-mutex))
- (run-id-list (if run-ids
- run-ids
- (rmt:get-all-run-ids)))
- (result '()))
- (if (null? run-id-list)
- '()
- (let loop ((hed (car run-id-list))
- (tal (cdr run-id-list))
- (threads '()))
- (if (> (length threads) 5)
- (loop hed tal (filter (lambda (th)(not (member (thread-state th) '(terminated dead)))) threads))
- (let* ((newthread (make-thread
- (lambda ()
- (let ((res (rmt:send-receive 'get-tests-for-run-mindata hed (list hed testpatt states status not-in))))
- (if (list? res)
- (begin
- (mutex-lock! multi-run-mutex)
- (set! result (append result res))
- (mutex-unlock! multi-run-mutex))
- (debug:print-error 0 *default-log-port* "get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in))))
- (conc "multi-run-thread for run-id " hed)))
- (newthreads (cons newthread threads)))
- (thread-start! newthread)
- (thread-sleep! 0.05) ;; give that thread some time to start
- (if (null? tal)
- newthreads
- (loop (car tal)(cdr tal) newthreads))))))
- result))
-
+
+;; (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
+;; ;;
+;; ;; grep define ../rmt.scm | grep rmt: |perl -pi -e 's/\(define\s+\((\S+)\W.*$/\1/'|sort -u
+;;
+;; ;;======================================================================
+;; ;; S U P P O R T F U N C T I O N S
+;; ;;======================================================================
+;;
+;; ;; if a server is either running or in the process of starting call client:setup
+;; ;; else return #f to let the calling proc know that there is no server available
+;; ;;
+;; (define (rmt:get-connection-info areapath runremote) ;; TODO: push areapath down.
+;; (let* ((cinfo (if (remote? runremote)
+;; (remote-conndat runremote)
+;; #f)))
+;; (if cinfo
+;; cinfo
+;; (if (server:check-if-running areapath)
+;; (client:setup areapath runremote)
+;; #f))))
+;;
+;; (define (rmt:on-homehost? runremote)
+;; (let* ((hh-dat (remote-hh-dat runremote)))
+;; (if (pair? hh-dat)
+;; (cdr hh-dat)
+;; (begin
+;; (debug:print-info 0 *default-log-port* "hh-dat="hh-dat)
+;; #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
+;;
+;; #;(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)))
+;; (if (and (> attemptnum 5) (= 0 (modulo attemptnum 15)))
+;; (begin (server:run *toppath*) (thread-sleep! 3)))
+;;
+;;
+;; ;;DOT digraph megatest_state_status {
+;; ;;DOT ranksep=0;
+;; ;;DOT // rankdir=LR;
+;; ;;DOT node [shape="box"];
+;; ;;DOT "rmt:send-receive" -> MUTEXLOCK;
+;; ;;DOT { edge [style=invis];"case 1" -> "case 2" -> "case 3" -> "case 4" -> "case 5" -> "case 6" -> "case 7" -> "case 8" -> "case 9" -> "case 10" -> "case 11"; }
+;; ;; do all the prep locked under the rmt-mutex
+;; (mutex-lock! *rmt-mutex*)
+;;
+;; ;; 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*)))
+;;
+;; ;; DOT INIT_RUNREMOTE; // leaving off - doesn't really add to the clarity
+;; ;; DOT MUTEXLOCK -> INIT_RUNREMOTE [label="no remote?"];
+;; ;; DOT INIT_RUNREMOTE -> MUTEXLOCK;
+;; ;; ensure we have a record for our connection for given area
+;; (if (not runremote) ;; can remove this one. should never get here.
+;; (begin
+;; (set! *runremote* (make-remote))
+;; (let* ((server-info (remote-server-info *runremote*)))
+;; (if server-info
+;; (begin
+;; (remote-server-url-set! *runremote* (server:record->url server-info))
+;; (remote-server-id-set! *runremote* (server:record->id server-info)))))
+;; (set! runremote *runremote*))) ;; new runremote will come from this on next iteration
+;;
+;; ;; DOT SET_HOMEHOST; // leaving off - doesn't really add to the clarity
+;; ;; DOT MUTEXLOCK -> SET_HOMEHOST [label="no homehost?"];
+;; ;; DOT SET_HOMEHOST -> MUTEXLOCK;
+;; ;; 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
+;; (let ((hh-data (server:choose-server areapath 'homehost)))
+;; (remote-hh-dat-set! runremote (or hh-data (cons #f #f)))))
+;;
+;; ;;(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))
+;;
+;; ;;DOT CASE2 [label="local\nreadonly\nquery"];
+;; ;;DOT MUTEXLOCK -> CASE2; {rank=same "case 2" CASE2}
+;; ;;DOT CASE2 -> "rmt:open-qry-close-locally";
+;; ;; readonly mode, read request- handle it - case 2
+;; ((and readonly-mode
+;; (member cmd api:read-only-queries))
+;; (mutex-unlock! *rmt-mutex*)
+;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 2")
+;; (rmt:open-qry-close-locally cmd 0 params)
+;; )
+;;
+;; ;;DOT CASE3 [label="write in\nread-only mode"];
+;; ;;DOT MUTEXLOCK -> CASE3 [label="readonly\nmode?"]; {rank=same "case 3" CASE3}
+;; ;;DOT CASE3 -> "#f";
+;; ;; readonly mode, write request. Do nothing, return #f
+;; (readonly-mode (extras-readonly-mode *rmt-mutex* *default-log-port* cmd params))
+;;
+;; ;; This block was for pre-emptively resetting the connection if there had been no communication for some time.
+;; ;; I don't think it adds any value. If the server is not there, just fail and start a new connection.
+;; ;; also, the expire-time calculation might not be correct. We want, time-since-last-server-access > (server:get-timeout)
+;; ;;
+;; ;;DOT CASE4 [label="reset\nconnection"];
+;; ;;DOT MUTEXLOCK -> CASE4 [label="have connection,\nlast_access > expire_time"]; {rank=same "case 4" CASE4}
+;; ;;DOT CASE4 -> "rmt:send-receive";
+;; ;; reset the connection if it has been unused too long
+;; ((and runremote
+;; ;; (remote-conndat runremote)
+;; (> (current-seconds) ;; if it has been more than server-timeout seconds since last contact, close this connection and start a new on
+;; (+ (remote-last-access runremote)
+;; (remote-server-timeout runremote))))
+;; (debug:print-info 0 *default-log-port* "Connection to " (remote-server-url runremote) " expired due to no accesses, forcing new connection.")
+;; (http-transport:close-connections runremote)
+;; ;; moving this setting of runremote conndat to #f to inside the http-transport:close-connections
+;; ;; (remote-conndat-set! runremote #f) ;; invalidate the connection, thus forcing a new connection.
+;; (mutex-unlock! *rmt-mutex*)
+;; (rmt:send-receive cmd rid params attemptnum: attemptnum))
+;;
+;; ;;DOT CASE5 [label="local\nread"];
+;; ;;DOT MUTEXLOCK -> CASE5 [label="server not required,\non homehost,\nread-only query"]; {rank=same "case 5" CASE5};
+;; ;;DOT CASE5 -> "rmt:open-qry-close-locally";
+;;
+;; ;; on homehost and this is a read
+;; ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
+;; (rmt:on-homehost? runremote)
+;; (member cmd api:read-only-queries)) ;; this is a read
+;; (mutex-unlock! *rmt-mutex*)
+;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5")
+;; (rmt:open-qry-close-locally cmd 0 params))
+;;
+;; ;;DOT CASE6 [label="init\nremote"];
+;; ;;DOT MUTEXLOCK -> CASE6 [label="on homehost,\nwrite query,\nhave server,\ncan't reach it"]; {rank=same "case 6" CASE6};
+;; ;;DOT CASE6 -> "rmt:send-receive";
+;; ;; on homehost and this is a write, we already have a server, but server has died
+;;
+;; ;; reinstate this keep-alive section but inject a time condition into the (add ...
+;; ;;
+;; ;; ((and (cdr (remote-hh-dat runremote)) ;; on homehost
+;; ;; (not (member cmd api:read-only-queries)) ;; this is a write
+;; ;; (remote-server-url runremote) ;; have a server
+;; ;; (not (server:ping (remote-server-url runremote) (remote-server-id runremote)))) ;; server has died. NOTE: this is not a cheap call! Need better approach.
+;; ;; (debug:print 0 *default-log-port* "WARNING: server appears to have died, trying to reconnect, case 6")
+;; ;; (http-transport:close-connections area-dat: runremote) ;; make sure to clean up
+;; ;; (set! *runremote* (make-remote))
+;; ;; (let* ((server-info (remote-server-info *runremote*)))
+;; ;; (if server-info
+;; ;; (begin
+;; ;; (remote-server-url-set! *runremote* (server:record->url server-info))
+;; ;; (remote-server-id-set! *runremote* (server:record->id server-info)))))
+;; ;; (remote-force-server-set! runremote (common:force-server?))
+;; ;; (mutex-unlock! *rmt-mutex*)
+;; ;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 6")
+;; ;; (rmt:send-receive cmd rid params attemptnum: attemptnum))
+;;
+;; ;;DOT CASE7 [label="homehost\nwrite"];
+;; ;;DOT MUTEXLOCK -> CASE7 [label="server not required,\non homehost,\na write,\nhave a server"]; {rank=same "case 7" CASE7};
+;; ;;DOT CASE7 -> "rmt:open-qry-close-locally";
+;; ;; on homehost and this is a write, we already have a server
+;; ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
+;; (cdr (remote-hh-dat runremote)) ;; on homehost
+;; (not (member cmd api:read-only-queries)) ;; this is a write
+;; (remote-server-url runremote)) ;; have a server
+;; (mutex-unlock! *rmt-mutex*)
+;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 4.1")
+;; (rmt:open-qry-close-locally cmd 0 params))
+;;
+;; ;;DOT CASE8 [label="force\nserver"];
+;; ;;DOT MUTEXLOCK -> CASE8 [label="server not required,\nhave homehost info,\nno connection yet,\nnot a read-only query"]; {rank=same "case 8" CASE8};
+;; ;;DOT CASE8 -> "rmt:open-qry-close-locally";
+;; ;; on homehost, no server contact made and this is a write, passively start a server
+;; ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
+;; (cdr (remote-hh-dat runremote)) ;; have homehost
+;; (not (remote-server-url runremote)) ;; no connection yet
+;; (not (member cmd api:read-only-queries))) ;; not a read-only query
+;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 8")
+;; (let ((server-info (server:check-if-running *toppath*))) ;; (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call
+;; (if server-info
+;; (begin
+;; (remote-server-url-set! runremote (server:record->url server-info)) ;; the string can be consumed by the client setup if needed
+;; (remote-server-id-set! runremote (server:record->id server-info)))
+;; (if (common:force-server?)
+;; (server:start-and-wait *toppath*)
+;; (server:kind-run *toppath*)))
+;; (remote-force-server-set! runremote (common:force-server?))
+;; (mutex-unlock! *rmt-mutex*)
+;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 8.1")
+;; (rmt:open-qry-close-locally cmd 0 params)))
+;;
+;; ;;DOT CASE9 [label="force server\nnot on homehost"];
+;; ;;DOT MUTEXLOCK -> CASE9 [label="no connection\nand either require server\nor not on homehost"]; {rank=same "case 9" CASE9};
+;; ;;DOT CASE9 -> "start\nserver" -> "rmt:send-receive";
+;; ((or (and (remote-force-server runremote) ;; we are forcing a server and don't yet have a connection to one
+;; (not (remote-conndat runremote)))
+;; (and (not (cdr (remote-hh-dat runremote))) ;; not on a homehost
+;; (not (remote-conndat runremote)))) ;; and no connection
+;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9, hh-dat: " (remote-hh-dat runremote) " conndat: " (remote-conndat runremote))
+;; (mutex-unlock! *rmt-mutex*)
+;; (if (not (server:check-if-running *toppath*)) ;; who knows, maybe one has started up?
+;; (server:start-and-wait *toppath*))
+;; (remote-conndat-set! runremote (rmt:get-connection-info *toppath* runremote)) ;; calls client:setup which calls client:setup-http
+;; (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;; TODO: add back-off timeout as
+;;
+;; ;;DOT CASE10 [label="on homehost"];
+;; ;;DOT MUTEXLOCK -> CASE10 [label="server not required,\non homehost"]; {rank=same "case 10" CASE10};
+;; ;;DOT CASE10 -> "rmt:open-qry-close-locally";
+;; ;; all set up if get this far, dispatch the query
+;; ((and (not (remote-force-server runremote))
+;; (cdr (remote-hh-dat runremote))) ;; we are on homehost
+;; (mutex-unlock! *rmt-mutex*)
+;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 10")
+;; (rmt:open-qry-close-locally cmd (if rid rid 0) params))
+;;
+;; ;;DOT CASE11 [label="send_receive"];
+;; ;;DOT MUTEXLOCK -> CASE11 [label="else"]; {rank=same "case 11" CASE11};
+;; ;;DOT CASE11 -> "rmt:send-receive" [label="call failed"];
+;; ;;DOT CASE11 -> "RESULT" [label="call succeeded"];
+;; ;; not on homehost, do server query
+;; (else (extras-case-11 *default-log-port* runremote cmd params attemptnum rid)))))
+;; ;;DOT }
+;;
+;; ;; bunch of small functions factored out of send-receive to make debug easier
+;; ;;
+;;
+;; (define (extras-case-11 *default-log-port* runremote cmd params attemptnum rid)
+;; ;; (mutex-unlock! *rmt-mutex*)
+;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9")
+;; ;; (mutex-lock! *rmt-mutex*)
+;; (let* ((conninfo (remote-conndat runremote))
+;; (dat-in (condition-case ;; handling here has
+;; ;; caused a lot of
+;; ;; problems. However it
+;; ;; is needed to deal with
+;; ;; attemtped
+;; ;; communication to
+;; ;; servers that have gone
+;; ;; away
+;; (http-transport:client-api-send-receive 0 runremote cmd params)
+;; ;; (http-transport:client-api-send-receive 0 conninfo cmd params runremote)
+;; ((servermismatch) (vector #f "Server id mismatch" ))
+;; ((commfail)(vector #f "communications fail"))
+;; ((exn)(vector #f "other fail" (print-call-chain)))))
+;; (dat (if (and (vector? dat-in) ;; ... check it is a correct size
+;; (> (vector-length dat-in) 1))
+;; dat-in
+;; (vector #f (conc "communications fail (type 2), dat-in=" dat-in))))
+;; (success (if (vector? dat) (vector-ref dat 0) #f))
+;; (res (if (vector? dat) (vector-ref dat 1) #f)))
+;; (if (and (vector? conninfo) (< 5 (vector-length conninfo)))
+;; (remote-last-access-set! runremote (current-seconds)) ;; refresh access time
+;; (begin
+;; (debug:print 0 *default-log-port* "INFO: Should not get here! conninfo=" conninfo)
+;; (set! conninfo #f)
+;; (http-transport:close-connections runremote)))
+;; (debug:print-info 13 *default-log-port* "rmt:send-receive, case 9. conninfo=" conninfo " dat=" dat " runremote = " runremote)
+;; (mutex-unlock! *rmt-mutex*)
+;; (if success ;; success only tells us that the transport was
+;; ;; successful, have to examine the data to see if
+;; ;; there was a detected issue at the other end
+;; (extras-transport-succeded *default-log-port* *rmt-mutex* attemptnum runremote res params rid cmd)
+;; (begin
+;; (debug:print-error 0 *default-log-port* " dat=" dat)
+;; (extras-transport-failed *default-log-port* *rmt-mutex* attemptnum runremote cmd rid params))
+;; )))
+;;
+;; (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)
+;; (let loop ((cmd (car cmds))
+;; (tal (cdr cmds))
+;; (max-cmd (car cmds))
+;; (res 0))
+;; (let* ((cmd-dat (hash-table-ref *db-stats* cmd))
+;; (tot (vector-ref cmd-dat 0))
+;; (curravg (/ (vector-ref cmd-dat 1) (vector-ref cmd-dat 0))) ;; count is never zero by construction
+;; (currmax (max res curravg))
+;; (newmax-cmd (if (> curravg res) cmd max-cmd)))
+;; (if (null? tal)
+;; (if (> tot 10)
+;; (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)
+;; (begin
+;; (debug:print-error 0 *default-log-port* "local query failed. Trying again.")
+;; (thread-sleep! (/ (random 5000) 1000)) ;; some random delay
+;; (rmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1)))
+;; (begin
+;; (debug:print-error 0 *default-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! *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 runremote cmd run-id params)
+;; (let* ((run-id (if run-id run-id 0))
+;; (res (http-transport:client-api-send-receive run-id runremote 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
+;; ;;
+;; ;;======================================================================
+;;
+;; ;;======================================================================
+;; ;; 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))))
+;;
+;; ;; hand off a call to one of the db:queries statements
+;; ;; added run-id to make looking up the correct db possible
+;; ;;
+;; (define (rmt:general-call stmtname run-id . params)
+;; (rmt:send-receive 'general-call run-id (append (list stmtname run-id) params)))
+;;
+;;
+;; ;; 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)
+;; (rmt:send-receive 'runtests run-id testpatt))
+;;
+;; (define (rmt:get-run-record-ids target run keynames test-patt)
+;; (rmt:send-receive 'get-run-record-ids #f (list target run keynames test-patt)))
+;;
+;; (define (rmt:get-changed-record-ids since-time)
+;; (rmt:send-receive 'get-changed-record-ids #f (list since-time)) )
+;;
+;; (define (rmt:drop-all-triggers)
+;; (rmt:send-receive 'drop-all-triggers #f '()))
+;;
+;; (define (rmt:create-all-triggers)
+;; (rmt:send-receive 'create-all-triggers #f '()))
+;;
+;; ;;======================================================================
+;; ;; T E S T M E T A
+;; ;;======================================================================
+;;
+;; (define (rmt:get-tests-tags)
+;; (rmt:send-receive 'get-tests-tags #f '()))
+;;
+;; ;;======================================================================
+;; ;; K E Y S
+;; ;;======================================================================
+;;
+;; ;; These require run-id because the values come from the run!
+;; ;;
+;; (define (rmt:get-key-val-pairs run-id)
+;; (rmt:send-receive 'get-key-val-pairs run-id (list run-id)))
+;;
+;; (define (rmt:get-keys)
+;; (if *db-keys* *db-keys*
+;; (let ((res (rmt:send-receive 'get-keys #f '())))
+;; (set! *db-keys* res)
+;; res)))
+;;
+;; (define (rmt:get-keys-write) ;; dummy query to force server start
+;; (let ((res (rmt:send-receive 'get-keys-write #f '())))
+;; (set! *db-keys* res)
+;; res))
+;;
+;; ;; we don't reuse run-id's (except possibly *after* a db cleanup) so it is safe
+;; ;; to cache the resuls in a hash
+;; ;;
+;; (define (rmt:get-key-vals run-id)
+;; (or (hash-table-ref/default *keyvals* run-id #f)
+;; (let ((res (rmt:send-receive 'get-key-vals #f (list run-id))))
+;; (hash-table-set! *keyvals* run-id res)
+;; res)))
+;;
+;; (define (rmt:get-targets)
+;; (rmt:send-receive 'get-targets #f '()))
+;;
+;; (define (rmt:get-target run-id)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'get-target run-id (list run-id)))
+;;
+;; (define (rmt:get-run-times runpatt targetpatt)
+;; (rmt:send-receive 'get-run-times #f (list runpatt targetpatt )))
+;;
+;;
+;; ;;======================================================================
+;; ;; T E S T S
+;; ;;======================================================================
+;;
+;; ;; Just some syntatic sugar
+;; (define (rmt:register-test run-id test-name item-path)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:general-call 'register-test run-id run-id test-name item-path))
+;;
+;; (define (rmt:get-test-id run-id testname item-path)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'get-test-id run-id (list run-id testname item-path)))
+;;
+;; ;; run-id is NOT used
+;; ;;
+;; (define (rmt:get-test-info-by-id run-id test-id)
+;; (if (number? test-id)
+;; (rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id))
+;; (begin
+;; (debug:print 0 *default-log-port* "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id)
+;; (print-call-chain (current-error-port))
+;; #f)))
+;;
+;; (define (rmt:test-get-rundir-from-test-id run-id test-id)
+;; (rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id)))
+;;
+;; (define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f))
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (let* ((test-path (if (string? work-area)
+;; work-area
+;; (rmt:test-get-rundir-from-test-id run-id test-id))))
+;; (debug:print 3 *default-log-port* "TEST PATH: " test-path)
+;; (open-test-db test-path)))
+;;
+;; ;; WARNING: This currently bypasses the transaction wrapped writes system
+;; (define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment)))
+;;
+;; (define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'set-tests-state-status run-id (list run-id testnames currstate currstatus newstate newstatus)))
+;;
+;; (define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; ;; (if (number? run-id)
+;; (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)))
+;; ;; (begin
+;; ;; (debug:print-error 0 *default-log-port* "rmt:get-tests-for-run called with bad run-id=" run-id)
+;; ;; (print-call-chain (current-error-port))
+;; ;; '())))
+;;
+;; (define (rmt:get-tests-for-run-state-status run-id testpatt last-update)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'get-tests-for-run-state-status run-id (list run-id testpatt last-update)))
+;;
+;; ;; get stuff via synchash
+;; (define (rmt:synchash-get run-id proc synckey keynum params)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'synchash-get run-id (list run-id proc synckey keynum params)))
+;;
+;; (define (rmt:get-tests-for-run-mindata run-id testpatt states status not-in)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-id testpatt states status not-in)))
+;;
;; ;; IDEA: Threadify these - they spend a lot of time waiting ...
;; ;;
;; (define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in)
-;; (let ((run-id-list (if run-ids
+;; (let ((multi-run-mutex (make-mutex))
+;; (run-id-list (if run-ids
;; run-ids
-;; (rmt:get-all-run-ids))))
-;; (apply append (map (lambda (run-id)
-;; (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-ids testpatt states status not-in)))
-;; run-id-list))))
-
-(define (rmt:delete-test-records run-id test-id)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'delete-test-records run-id (list run-id test-id)))
-
-(define (rmt:test-set-state-status run-id test-id state status msg)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'test-set-state-status run-id (list run-id test-id state status msg)))
-
-(define (rmt:test-toplevel-num-items run-id test-name)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'test-toplevel-num-items run-id (list run-id test-name)))
-
-;; (define (rmt:get-previous-test-run-record run-id test-name item-path)
-;; (rmt:send-receive 'get-previous-test-run-record run-id (list run-id test-name item-path)))
-
-(define (rmt:get-matching-previous-test-run-records run-id test-name item-path)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'get-matching-previous-test-run-records run-id (list run-id test-name item-path)))
-
-(define (rmt:test-get-logfile-info run-id test-name)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'test-get-logfile-info run-id (list run-id test-name)))
-
-(define (rmt:test-get-records-for-index-file run-id test-name)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'test-get-records-for-index-file run-id (list run-id test-name)))
-
-(define (rmt:get-testinfo-state-status run-id test-id)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'get-testinfo-state-status run-id (list run-id test-id)))
-
-(define (rmt:test-set-log! run-id test-id logf)
- (assert (number? run-id) "FATAL: Run id required.")
- (if (string? logf)(rmt:general-call 'test-set-log run-id logf test-id)))
-
-(define (rmt:test-set-top-process-pid run-id test-id pid)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'test-set-top-process-pid run-id (list run-id test-id pid)))
-
-(define (rmt:test-get-top-process-pid run-id test-id)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'test-get-top-process-pid run-id (list run-id test-id)))
-
-(define (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt)
- (rmt:send-receive 'get-run-ids-matching-target #f (list keynames target res runname testpatt statepatt statuspatt)))
-
-;; NOTE: This will open and access ALL run databases.
-;;
-(define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname)
- (let ((run-ids (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt)))
- (apply append
- (map (lambda (run-id)
- (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname)))
- run-ids))))
-
-(define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f))
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-test-name ref-item-path mode itemmaps)))
-
-(define (rmt:get-count-tests-running-for-run-id run-id)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id)))
-
-(define (rmt:get-not-completed-cnt run-id)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'get-not-completed-cnt run-id (list run-id)))
-
-
-;; Statistical queries
-
-(define (rmt:get-count-tests-running run-id)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'get-count-tests-running run-id (list run-id)))
-
-(define (rmt:get-count-tests-running-for-testname run-id testname)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'get-count-tests-running-for-testname run-id (list run-id testname)))
-
-(define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup)))
-
-;; state and status are extra hints not usually used in the calculation
-;;
-(define (rmt:set-state-status-and-roll-up-items run-id test-name item-path state status comment)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'set-state-status-and-roll-up-items run-id (list run-id test-name item-path state status comment)))
-
-(define (rmt:set-state-status-and-roll-up-run run-id state status)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'set-state-status-and-roll-up-run run-id (list run-id state status)))
-
-
-(define (rmt:update-pass-fail-counts run-id test-name)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:general-call 'update-pass-fail-counts run-id test-name test-name test-name))
-
-(define (rmt:top-test-set-per-pf-counts run-id test-name)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'top-test-set-per-pf-counts run-id (list run-id test-name)))
-
-(define (rmt:get-raw-run-stats run-id)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'get-raw-run-stats run-id (list run-id)))
-
-(define (rmt:get-test-times runname target)
- (rmt:send-receive 'get-test-times #f (list runname target )))
-
-;;======================================================================
-;; R U N S
-;;======================================================================
-
-;; BUG - LOOK AT HOW THIS WORKS!!!
-;;
-(define (rmt:get-run-info run-id)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'get-run-info #f (list run-id)))
-
-(define (rmt:get-num-runs runpatt)
- (rmt:send-receive 'get-num-runs #f (list runpatt)))
-
-(define (rmt:get-runs-cnt-by-patt runpatt targetpatt keys)
- (rmt:send-receive 'get-runs-cnt-by-patt #f (list runpatt targetpatt keys)))
-
-;; Use the special run-id == #f scenario here since there is no run yet
-(define (rmt:register-run keyvals runname state status user contour)
- (rmt:send-receive 'register-run #f (list keyvals runname state status user contour)))
-
-(define (rmt:get-run-name-from-id run-id)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'get-run-name-from-id #f (list run-id)))
-
-(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)))
-
-(define (rmt:get-all-run-ids)
- (rmt:send-receive 'get-all-run-ids #f '()))
-
-(define (rmt:get-prev-run-ids run-id)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'get-prev-run-ids #f (list run-id)))
-
-(define (rmt:lock/unlock-run run-id lock unlock user)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'lock/unlock-run #f (list run-id lock unlock user)))
-
-;; set/get status
-(define (rmt:get-run-status run-id)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'get-run-status #f (list run-id)))
-
-(define (rmt:get-run-state run-id)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'get-run-state #f (list run-id)))
-
-
-(define (rmt:set-run-status run-id run-status #!key (msg #f))
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'set-run-status #f (list run-id run-status msg)))
-
-(define (rmt:set-run-state-status run-id state status )
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'set-run-state-status #f (list run-id state status)))
-
-(define (rmt:update-tesdata-on-repilcate-db old-lt new-lt)
-(rmt:send-receive 'update-tesdata-on-repilcate-db #f (list old-lt new-lt)))
-
-(define (rmt:update-run-event_time run-id)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'update-run-event_time #f (list run-id)))
-
-(define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-runs-update #!key (sort-order "asc")) ;; fields of #f uses default
- (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit fields last-runs-update sort-order)))
-
-(define (rmt:find-and-mark-incomplete run-id ovr-deadtime)
- (assert (number? run-id) "FATAL: Run id required.")
- ;; (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime))
- (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime))) ;; )
-
-(define (rmt:get-main-run-stats run-id)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'get-main-run-stats #f (list run-id)))
-
-(define (rmt:get-var varname)
- (rmt:send-receive 'get-var #f (list varname)))
-
-(define (rmt:del-var varname)
- (rmt:send-receive 'del-var #f (list varname)))
-
-(define (rmt:set-var varname value)
- (rmt:send-receive 'set-var #f (list varname value)))
-
-(define (rmt:inc-var varname)
- (rmt:send-receive 'inc-var #f (list varname)))
-
-(define (rmt:dec-var varname)
- (rmt:send-receive 'dec-var #f (list varname)))
-
-(define (rmt:add-var varname value)
- (rmt:send-receive 'add-var #f (list varname value)))
-
-;;======================================================================
-;; M U L T I R U N Q U E R I E S
-;;======================================================================
-
-;; Need to move this to multi-run section and make associated changes
-(define (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f))
- (let ((run-ids (rmt:get-all-run-ids)))
- (for-each (lambda (run-id)
- (rmt:find-and-mark-incomplete run-id ovr-deadtime))
- run-ids)))
-
-;; get the previous record for when this test was run where all keys match but runname
-;; returns #f if no such test found, returns a single test record if found
-;;
-;; Run this at the client end since we have to connect to multiple run-id dbs
-;;
-(define (rmt:get-previous-test-run-record run-id test-name item-path)
- (let* ((keyvals (rmt:get-key-val-pairs run-id))
- (keys (rmt:get-keys))
- (selstr (string-intersperse keys ","))
- (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")))
- (if (not keyvals)
- #f
- (let ((prev-run-ids (rmt:get-prev-run-ids run-id)))
- ;; for each run starting with the most recent look to see if there is a matching test
- ;; if found then return that matching test record
- (debug:print 4 *default-log-port* "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids)
- (if (null? prev-run-ids) #f
- (let loop ((hed (car prev-run-ids))
- (tal (cdr prev-run-ids)))
- (let ((results (rmt:get-tests-for-run hed (conc test-name "/" item-path) '() '() ;; run-id testpatt states statuses
- #f #f #f ;; offset limit not-in hide/not-hide
- #f #f #f #f 'normal))) ;; sort-by sort-order qryvals last-update mode
- (debug:print 4 *default-log-port* "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results)
- (if (and (null? results)
- (not (null? tal)))
- (loop (car tal)(cdr tal))
- (if (null? results) #f
- (car results))))))))))
-
-(define (rmt:get-run-stats)
- (rmt:send-receive 'get-run-stats #f '()))
-
-;;======================================================================
-;; S T E P S
-;;======================================================================
-
-;; Getting steps is more complicated.
-;;
-;; If given work area
-;; 1. Find the testdat.db file
-;; 2. Open the testdat.db file and do the query
-;; If not given the work area
-;; 1. Do a remote call to get the test path
-;; 2. Continue as above
-;;
-;;(define (rmt:get-steps-for-test run-id test-id)
-;; (rmt:send-receive 'get-steps-data run-id (list test-id)))
-
-(define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile)
- (assert (number? run-id) "FATAL: Run id required.")
- (let* ((state (items:check-valid-items "state" state-in))
- (status (items:check-valid-items "status" status-in)))
- (if (or (not state)(not status))
- (debug:print 3 *default-log-port* "WARNING: Invalid " (if status "status" "state")
- " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config"))
- (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile))))
-
-
-(define (rmt:delete-steps-for-test! run-id test-id)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'delete-steps-for-test! run-id (list run-id test-id)))
-
-(define (rmt:get-steps-for-test run-id test-id)
- (assert (number? run-id) "FATAL: Run id required.")
- (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)
- (assert (number? run-id) "FATAL: Run id required.")
- (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))
- (assert (number? run-id) "FATAL: Run id required.")
- (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))
- (assert (number? run-id) "FATAL: Run id required.")
- (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)
- (assert (number? run-id) "FATAL: Run id required.")
- (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)))
-
-(define (rmt:testmeta-update-field test-name fld val)
- (rmt:send-receive 'testmeta-update-field #f (list test-name fld val)))
-
-(define (rmt:test-data-rollup run-id test-id status)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'test-data-rollup run-id (list run-id test-id status)))
-
-(define (rmt:csv->test-data run-id test-id csvdata)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'csv->test-data run-id (list run-id test-id csvdata)))
-
-;;======================================================================
-;; T A S K S
-;;======================================================================
-
-(define (rmt:tasks-find-task-queue-records target run-name test-patt state-patt action-patt)
- (rmt:send-receive 'find-task-queue-records #f (list target run-name test-patt state-patt action-patt)))
-
-(define (rmt:tasks-add action owner target runname testpatt params)
- (rmt:send-receive 'tasks-add #f (list action owner target runname testpatt params)))
-
-(define (rmt:tasks-set-state-given-param-key param-key new-state)
- (rmt:send-receive 'tasks-set-state-given-param-key #f (list param-key new-state)))
-
-(define (rmt:tasks-get-last target runname)
- (rmt:send-receive 'tasks-get-last #f (list target runname)))
-
-;;======================================================================
-;; N O S Y N C D B
-;;======================================================================
-
-(define (rmt:no-sync-set var val)
- (rmt:send-receive 'no-sync-set #f `(,var ,val)))
-
-(define (rmt:no-sync-get/default var default)
- (rmt:send-receive 'no-sync-get/default #f `(,var ,default)))
-
-(define (rmt:no-sync-del! var)
- (rmt:send-receive 'no-sync-del! #f `(,var)))
-
-(define (rmt:no-sync-get-lock keyname)
- (rmt:send-receive 'no-sync-get-lock #f `(,keyname)))
-
-;;======================================================================
-;; A R C H I V E S
-;;======================================================================
-
-(define (rmt:archive-get-allocations testname itempath dneeded)
- (rmt:send-receive 'archive-get-allocations #f (list testname itempath dneeded)))
-
-(define (rmt:archive-register-block-name bdisk-id archive-path)
- (rmt:send-receive 'archive-register-block-name #f (list bdisk-id archive-path)))
-
-(define (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey)
- (rmt:send-receive 'archive-allocate-test-to-block #f (list block-id testsuite-name areakey)))
-
-(define (rmt:archive-register-disk bdisk-name bdisk-path df)
- (rmt:send-receive 'archive-register-disk #f (list bdisk-name bdisk-path df)))
-
-(define (rmt:test-set-archive-block-id run-id test-id archive-block-id)
- (assert (number? run-id) "FATAL: Run id required.")
- (rmt:send-receive 'test-set-archive-block-id run-id (list run-id test-id archive-block-id)))
-
-(define (rmt:test-get-archive-block-info archive-block-id)
- (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))))
-
-(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*)
- (http-transport:close-connections 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 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
-
-#;(set-functions rmt:send-receive remote-server-url-set!
- http-transport:close-connections remote-conndat-set!
- debug:print debug:print-info
- remote-ro-mode remote-ro-mode-set!
- remote-ro-mode-checked-set! remote-ro-mode-checked)
+;; (rmt:get-all-run-ids)))
+;; (result '()))
+;; (if (null? run-id-list)
+;; '()
+;; (let loop ((hed (car run-id-list))
+;; (tal (cdr run-id-list))
+;; (threads '()))
+;; (if (> (length threads) 5)
+;; (loop hed tal (filter (lambda (th)(not (member (thread-state th) '(terminated dead)))) threads))
+;; (let* ((newthread (make-thread
+;; (lambda ()
+;; (let ((res (rmt:send-receive 'get-tests-for-run-mindata hed (list hed testpatt states status not-in))))
+;; (if (list? res)
+;; (begin
+;; (mutex-lock! multi-run-mutex)
+;; (set! result (append result res))
+;; (mutex-unlock! multi-run-mutex))
+;; (debug:print-error 0 *default-log-port* "get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in))))
+;; (conc "multi-run-thread for run-id " hed)))
+;; (newthreads (cons newthread threads)))
+;; (thread-start! newthread)
+;; (thread-sleep! 0.05) ;; give that thread some time to start
+;; (if (null? tal)
+;; newthreads
+;; (loop (car tal)(cdr tal) newthreads))))))
+;; result))
+;;
+;; ;; ;; IDEA: Threadify these - they spend a lot of time waiting ...
+;; ;; ;;
+;; ;; (define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in)
+;; ;; (let ((run-id-list (if run-ids
+;; ;; run-ids
+;; ;; (rmt:get-all-run-ids))))
+;; ;; (apply append (map (lambda (run-id)
+;; ;; (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-ids testpatt states status not-in)))
+;; ;; run-id-list))))
+;;
+;; (define (rmt:delete-test-records run-id test-id)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'delete-test-records run-id (list run-id test-id)))
+;;
+;; (define (rmt:test-set-state-status run-id test-id state status msg)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'test-set-state-status run-id (list run-id test-id state status msg)))
+;;
+;; (define (rmt:test-toplevel-num-items run-id test-name)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'test-toplevel-num-items run-id (list run-id test-name)))
+;;
+;; ;; (define (rmt:get-previous-test-run-record run-id test-name item-path)
+;; ;; (rmt:send-receive 'get-previous-test-run-record run-id (list run-id test-name item-path)))
+;;
+;; (define (rmt:get-matching-previous-test-run-records run-id test-name item-path)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'get-matching-previous-test-run-records run-id (list run-id test-name item-path)))
+;;
+;; (define (rmt:test-get-logfile-info run-id test-name)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'test-get-logfile-info run-id (list run-id test-name)))
+;;
+;; (define (rmt:test-get-records-for-index-file run-id test-name)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'test-get-records-for-index-file run-id (list run-id test-name)))
+;;
+;; (define (rmt:get-testinfo-state-status run-id test-id)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'get-testinfo-state-status run-id (list run-id test-id)))
+;;
+;; (define (rmt:test-set-log! run-id test-id logf)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (if (string? logf)(rmt:general-call 'test-set-log run-id logf test-id)))
+;;
+;; (define (rmt:test-set-top-process-pid run-id test-id pid)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'test-set-top-process-pid run-id (list run-id test-id pid)))
+;;
+;; (define (rmt:test-get-top-process-pid run-id test-id)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'test-get-top-process-pid run-id (list run-id test-id)))
+;;
+;; (define (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt)
+;; (rmt:send-receive 'get-run-ids-matching-target #f (list keynames target res runname testpatt statepatt statuspatt)))
+;;
+;; ;; NOTE: This will open and access ALL run databases.
+;; ;;
+;; (define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname)
+;; (let ((run-ids (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt)))
+;; (apply append
+;; (map (lambda (run-id)
+;; (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname)))
+;; run-ids))))
+;;
+;; (define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f))
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-test-name ref-item-path mode itemmaps)))
+;;
+;; (define (rmt:get-count-tests-running-for-run-id run-id)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id)))
+;;
+;; (define (rmt:get-not-completed-cnt run-id)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'get-not-completed-cnt run-id (list run-id)))
+;;
+;;
+;; ;; Statistical queries
+;;
+;; (define (rmt:get-count-tests-running run-id)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'get-count-tests-running run-id (list run-id)))
+;;
+;; (define (rmt:get-count-tests-running-for-testname run-id testname)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'get-count-tests-running-for-testname run-id (list run-id testname)))
+;;
+;; (define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup)))
+;;
+;; ;; state and status are extra hints not usually used in the calculation
+;; ;;
+;; (define (rmt:set-state-status-and-roll-up-items run-id test-name item-path state status comment)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'set-state-status-and-roll-up-items run-id (list run-id test-name item-path state status comment)))
+;;
+;; (define (rmt:set-state-status-and-roll-up-run run-id state status)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'set-state-status-and-roll-up-run run-id (list run-id state status)))
+;;
+;;
+;; (define (rmt:update-pass-fail-counts run-id test-name)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:general-call 'update-pass-fail-counts run-id test-name test-name test-name))
+;;
+;; (define (rmt:top-test-set-per-pf-counts run-id test-name)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'top-test-set-per-pf-counts run-id (list run-id test-name)))
+;;
+;; (define (rmt:get-raw-run-stats run-id)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'get-raw-run-stats run-id (list run-id)))
+;;
+;; (define (rmt:get-test-times runname target)
+;; (rmt:send-receive 'get-test-times #f (list runname target )))
+;;
+;; ;;======================================================================
+;; ;; R U N S
+;; ;;======================================================================
+;;
+;; ;; BUG - LOOK AT HOW THIS WORKS!!!
+;; ;;
+;; (define (rmt:get-run-info run-id)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'get-run-info #f (list run-id)))
+;;
+;; (define (rmt:get-num-runs runpatt)
+;; (rmt:send-receive 'get-num-runs #f (list runpatt)))
+;;
+;; (define (rmt:get-runs-cnt-by-patt runpatt targetpatt keys)
+;; (rmt:send-receive 'get-runs-cnt-by-patt #f (list runpatt targetpatt keys)))
+;;
+;; ;; Use the special run-id == #f scenario here since there is no run yet
+;; (define (rmt:register-run keyvals runname state status user contour)
+;; (rmt:send-receive 'register-run #f (list keyvals runname state status user contour)))
+;;
+;; (define (rmt:get-run-name-from-id run-id)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'get-run-name-from-id #f (list run-id)))
+;;
+;; (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)))
+;;
+;; (define (rmt:get-all-run-ids)
+;; (rmt:send-receive 'get-all-run-ids #f '()))
+;;
+;; (define (rmt:get-prev-run-ids run-id)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'get-prev-run-ids #f (list run-id)))
+;;
+;; (define (rmt:lock/unlock-run run-id lock unlock user)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'lock/unlock-run #f (list run-id lock unlock user)))
+;;
+;; ;; set/get status
+;; (define (rmt:get-run-status run-id)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'get-run-status #f (list run-id)))
+;;
+;; (define (rmt:get-run-state run-id)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'get-run-state #f (list run-id)))
+;;
+;;
+;; (define (rmt:set-run-status run-id run-status #!key (msg #f))
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'set-run-status #f (list run-id run-status msg)))
+;;
+;; (define (rmt:set-run-state-status run-id state status )
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'set-run-state-status #f (list run-id state status)))
+;;
+;; (define (rmt:update-tesdata-on-repilcate-db old-lt new-lt)
+;; (rmt:send-receive 'update-tesdata-on-repilcate-db #f (list old-lt new-lt)))
+;;
+;; (define (rmt:update-run-event_time run-id)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'update-run-event_time #f (list run-id)))
+;;
+;; (define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-runs-update #!key (sort-order "asc")) ;; fields of #f uses default
+;; (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit fields last-runs-update sort-order)))
+;;
+;; (define (rmt:find-and-mark-incomplete run-id ovr-deadtime)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; ;; (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime))
+;; (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime))) ;; )
+;;
+;; (define (rmt:get-main-run-stats run-id)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'get-main-run-stats #f (list run-id)))
+;;
+;; (define (rmt:get-var varname)
+;; (rmt:send-receive 'get-var #f (list varname)))
+;;
+;; (define (rmt:del-var varname)
+;; (rmt:send-receive 'del-var #f (list varname)))
+;;
+;; (define (rmt:set-var varname value)
+;; (rmt:send-receive 'set-var #f (list varname value)))
+;;
+;; (define (rmt:inc-var varname)
+;; (rmt:send-receive 'inc-var #f (list varname)))
+;;
+;; (define (rmt:dec-var varname)
+;; (rmt:send-receive 'dec-var #f (list varname)))
+;;
+;; (define (rmt:add-var varname value)
+;; (rmt:send-receive 'add-var #f (list varname value)))
+;;
+;; ;;======================================================================
+;; ;; M U L T I R U N Q U E R I E S
+;; ;;======================================================================
+;;
+;; ;; Need to move this to multi-run section and make associated changes
+;; (define (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f))
+;; (let ((run-ids (rmt:get-all-run-ids)))
+;; (for-each (lambda (run-id)
+;; (rmt:find-and-mark-incomplete run-id ovr-deadtime))
+;; run-ids)))
+;;
+;; ;; get the previous record for when this test was run where all keys match but runname
+;; ;; returns #f if no such test found, returns a single test record if found
+;; ;;
+;; ;; Run this at the client end since we have to connect to multiple run-id dbs
+;; ;;
+;; (define (rmt:get-previous-test-run-record run-id test-name item-path)
+;; (let* ((keyvals (rmt:get-key-val-pairs run-id))
+;; (keys (rmt:get-keys))
+;; (selstr (string-intersperse keys ","))
+;; (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")))
+;; (if (not keyvals)
+;; #f
+;; (let ((prev-run-ids (rmt:get-prev-run-ids run-id)))
+;; ;; for each run starting with the most recent look to see if there is a matching test
+;; ;; if found then return that matching test record
+;; (debug:print 4 *default-log-port* "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids)
+;; (if (null? prev-run-ids) #f
+;; (let loop ((hed (car prev-run-ids))
+;; (tal (cdr prev-run-ids)))
+;; (let ((results (rmt:get-tests-for-run hed (conc test-name "/" item-path) '() '() ;; run-id testpatt states statuses
+;; #f #f #f ;; offset limit not-in hide/not-hide
+;; #f #f #f #f 'normal))) ;; sort-by sort-order qryvals last-update mode
+;; (debug:print 4 *default-log-port* "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results)
+;; (if (and (null? results)
+;; (not (null? tal)))
+;; (loop (car tal)(cdr tal))
+;; (if (null? results) #f
+;; (car results))))))))))
+;;
+;; (define (rmt:get-run-stats)
+;; (rmt:send-receive 'get-run-stats #f '()))
+;;
+;; ;;======================================================================
+;; ;; S T E P S
+;; ;;======================================================================
+;;
+;; ;; Getting steps is more complicated.
+;; ;;
+;; ;; If given work area
+;; ;; 1. Find the testdat.db file
+;; ;; 2. Open the testdat.db file and do the query
+;; ;; If not given the work area
+;; ;; 1. Do a remote call to get the test path
+;; ;; 2. Continue as above
+;; ;;
+;; ;;(define (rmt:get-steps-for-test run-id test-id)
+;; ;; (rmt:send-receive 'get-steps-data run-id (list test-id)))
+;;
+;; (define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (let* ((state (items:check-valid-items "state" state-in))
+;; (status (items:check-valid-items "status" status-in)))
+;; (if (or (not state)(not status))
+;; (debug:print 3 *default-log-port* "WARNING: Invalid " (if status "status" "state")
+;; " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config"))
+;; (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile))))
+;;
+;;
+;; (define (rmt:delete-steps-for-test! run-id test-id)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'delete-steps-for-test! run-id (list run-id test-id)))
+;;
+;; (define (rmt:get-steps-for-test run-id test-id)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (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)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (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))
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (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))
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (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)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (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)))
+;;
+;; (define (rmt:testmeta-update-field test-name fld val)
+;; (rmt:send-receive 'testmeta-update-field #f (list test-name fld val)))
+;;
+;; (define (rmt:test-data-rollup run-id test-id status)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'test-data-rollup run-id (list run-id test-id status)))
+;;
+;; (define (rmt:csv->test-data run-id test-id csvdata)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'csv->test-data run-id (list run-id test-id csvdata)))
+;;
+;; ;;======================================================================
+;; ;; T A S K S
+;; ;;======================================================================
+;;
+;; (define (rmt:tasks-find-task-queue-records target run-name test-patt state-patt action-patt)
+;; (rmt:send-receive 'find-task-queue-records #f (list target run-name test-patt state-patt action-patt)))
+;;
+;; (define (rmt:tasks-add action owner target runname testpatt params)
+;; (rmt:send-receive 'tasks-add #f (list action owner target runname testpatt params)))
+;;
+;; (define (rmt:tasks-set-state-given-param-key param-key new-state)
+;; (rmt:send-receive 'tasks-set-state-given-param-key #f (list param-key new-state)))
+;;
+;; (define (rmt:tasks-get-last target runname)
+;; (rmt:send-receive 'tasks-get-last #f (list target runname)))
+;;
+;; ;;======================================================================
+;; ;; N O S Y N C D B
+;; ;;======================================================================
+;;
+;; (define (rmt:no-sync-set var val)
+;; (rmt:send-receive 'no-sync-set #f `(,var ,val)))
+;;
+;; (define (rmt:no-sync-get/default var default)
+;; (rmt:send-receive 'no-sync-get/default #f `(,var ,default)))
+;;
+;; (define (rmt:no-sync-del! var)
+;; (rmt:send-receive 'no-sync-del! #f `(,var)))
+;;
+;; (define (rmt:no-sync-get-lock keyname)
+;; (rmt:send-receive 'no-sync-get-lock #f `(,keyname)))
+;;
+;; ;;======================================================================
+;; ;; A R C H I V E S
+;; ;;======================================================================
+;;
+;; (define (rmt:archive-get-allocations testname itempath dneeded)
+;; (rmt:send-receive 'archive-get-allocations #f (list testname itempath dneeded)))
+;;
+;; (define (rmt:archive-register-block-name bdisk-id archive-path)
+;; (rmt:send-receive 'archive-register-block-name #f (list bdisk-id archive-path)))
+;;
+;; (define (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey)
+;; (rmt:send-receive 'archive-allocate-test-to-block #f (list block-id testsuite-name areakey)))
+;;
+;; (define (rmt:archive-register-disk bdisk-name bdisk-path df)
+;; (rmt:send-receive 'archive-register-disk #f (list bdisk-name bdisk-path df)))
+;;
+;; (define (rmt:test-set-archive-block-id run-id test-id archive-block-id)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; (rmt:send-receive 'test-set-archive-block-id run-id (list run-id test-id archive-block-id)))
+;;
+;; (define (rmt:test-get-archive-block-info archive-block-id)
+;; (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))))
+;;
+;; (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*)
+;; (http-transport:close-connections 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 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
+;;
+;; #;(set-functions rmt:send-receive remote-server-url-set!
+;; http-transport:close-connections remote-conndat-set!
+;; debug:print debug:print-info
+;; remote-ro-mode remote-ro-mode-set!
+;; remote-ro-mode-checked-set! remote-ro-mode-checked)
+;;
Index: rmtmod.scm
==================================================================
--- rmtmod.scm
+++ rmtmod.scm
@@ -18,68 +18,10 @@
;;======================================================================
(declare (unit rmtmod))
(declare (uses commonmod))
-(declare (uses apimod))
-;; (declare (uses apimod.import))
-(declare (uses ulex))
-
-;; (include "ulex/ulex.scm")
(module rmtmod
*
-(import scheme chicken data-structures extras)
-(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
-(import (prefix commonmod cmod:))
-(import apimod)
-(import (prefix ulex ulex:))
-
-(defstruct alldat
- (areapath #f)
- (ulexdat #f)
- )
-
-;;======================================================================
-;; return the handle struct for sending queries to a specific database
-;; - initializes the connection object if this is the first access
-;; - finds the "captain" and asks who to talk to for the given dbfname
-;; - establishes the connection to the current dbowner
-;;
-#;(define (rmt:connect alldat dbfname dbtype)
- (let* ((ulexdat (or (alldat-ulexdat alldat)
- (rmt:setup-ulex alldat))))
- (ulex:connect ulexdat dbfname dbtype)))
-
-;; setup the remote calls
-#;(define (rmt:setup-ulex alldat)
- (let* ((udata (ulex:setup))) ;; establish connection to ulex
- (alldat-ulexdat-set! alldat udata)
- ;; register all needed procs
- (ulex:register-handler udata 'ping cmod:get-full-version) ;; override ping with get-full-version
- (ulex:register-handler udata 'login cmod:get-full-version) ;; force setup of the connection
- (ulex:register-handler udata 'execute api:execute-requests)
- udata))
-
-;; set up a connection to the current owner of the dbfile associated with rid
-;; then send the query to that dbfile owner and wait for a response.
-;;
-#;(define (rmt:send-receive alldat cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected
- (let* (;; (alldat *alldat*)
- (areapath (alldat-areapath alldat))
- (dbtype (if (or (not rid)(< rid 1)) ;; this is the criteria for "main.db"
- "main" "runs"))
- (dbfname (if (equal? dbtype "main")
- "main.db"
- (conc rid ".db")))
- (dbfile (conc areapath "/.db/" dbfname))
- (ulexconn (rmt:connect alldat dbfname dbtype)) ;; ulexconn is our new *runremote*, it is a dbowner struct < pdat lastrefresh >
- (udata (alldat-ulexdat alldat)))
- (ulex:remote-request udata ulexconn 'immediate dbfile 'execute rid params)))
- ;; need to call this on the other side
- ;; (api:execute-requests dbstruct-local (vector (symbol->string cmd) params))))
-
- #;(with-input-from-string
- (ulex:remote-request udata ulexconn 'immediate dbfile 'execute rid (with-output-to-string (lambda ()(serialize params))))
- (lambda ()(deserialize)))
)
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -25,11 +25,11 @@
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
-(declare (uses server))
+(declare (uses servermod))
(declare (uses mt))
(declare (uses archive))
;; (declare (uses filedb))
(include "common_records.scm")
Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -14,857 +14,858 @@
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
-(require-extension (srfi 18) extras tcp s11n)
-
-(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest
- directory-utils posix-extras matchable utils)
-
-(use spiffy uri-common intarweb http-client spiffy-request-vars)
-
-(declare (unit server))
-
-(declare (uses commonmod))
-
-(declare (uses common))
-(declare (uses db))
-(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
-;; (declare (uses synchash))
-(declare (uses http-transport))
-;;(declare (uses rpc-transport))
-(declare (uses launch))
-;; (declare (uses daemon))
-
-(import commonmod)
-
-(include "common_records.scm")
-(include "db_records.scm")
-
-(define (server:make-server-url hostport)
- (if (not hostport)
- #f
- (conc "http://" (car hostport) ":" (cadr hostport))))
-
-(define *server-loop-heart-beat* (current-seconds))
-
-;;======================================================================
-;; P K T S S T U F F
-;;======================================================================
-
-;; ???
-
-;;======================================================================
-;; P K T S S T U F F
-;;======================================================================
-
-;; ???
-
-;;======================================================================
-;; S E R V E R
-;;======================================================================
-
-;; Call this to start the actual server
-;;
-
-;;======================================================================
-;; S E R V E R U T I L I T I E S
-;;======================================================================
-
-;; Get the transport
-(define (server:get-transport)
- (if *transport-type*
- *transport-type*
- (let ((ttype (string->symbol
- (or (args:get-arg "-transport")
- (configf:lookup *configdat* "server" "transport")
- "rpc"))))
- (set! *transport-type* ttype)
- ttype)))
-
-;; Generate a unique signature for this server
-(define (server:mk-signature)
- (message-digest-string (md5-primitive)
- (with-output-to-string
- (lambda ()
- (write (list (current-directory)
- (current-process-id)
- (argv)))))))
-
-(define (server:get-client-signature)
- (if *my-client-signature* *my-client-signature*
- (let ((sig (server:mk-signature))) ;; clients re-use the server:mk-signature logic
- (set! *my-client-signature* sig)
- *my-client-signature*)))
-
-(define (server:get-server-id)
- (if *server-id* *server-id*
- (let ((sig (server:mk-signature))) ;; clients re-use the server:mk-signature logic
- (set! *server-id* sig)
- *server-id*)))
-
-;; When using zmq this would send the message back (two step process)
-;; with spiffy or rpc this simply returns the return data to be returned
-;;
-(define (server:reply return-addr query-sig success/fail result)
- (debug:print-info 11 *default-log-port* "server:reply return-addr=" return-addr ", result=" result)
- ;; (send-message pubsock target send-more: #t)
- ;; (send-message pubsock
- (case (server:get-transport)
- ((rpc) (db:obj->string (vector success/fail query-sig result)))
- ((http) (db:obj->string (vector success/fail query-sig result)))
- ((fs) result)
- (else
- (debug:print-error 0 *default-log-port* "unrecognised transport type: " *transport-type*)
- result)))
-
-;; Given an area path, start a server process ### NOTE ### > file 2>&1
-;; if the target-host is set
-;; try running on that host
-;; incidental: rotate logs in logs/ dir.
-;;
-(define (server:run areapath) ;; areapath is *toppath* for a given testsuite area
- (let* ((testsuite (common:get-testsuite-name))
- (logfile (conc areapath "/logs/server.log")) ;; -" curr-pid "-" target-host ".log"))
- (profile-mode (or (configf:lookup *configdat* "misc" "profilesw")
- ""))
- (cmdln (conc (common:get-megatest-exe)
- " -server - ";; (or target-host "-")
- (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
- " -daemonize "
- "")
- ;; " -log " logfile
- " -m testsuite:" testsuite
- " " profile-mode
- )) ;; (conc " >> " logfile " 2>&1 &")))))
- (log-rotate (make-thread common:rotate-logs "server run, rotate logs thread")) ;; why are we rotating logs here? This is a sensitive location with a lot going on!?
- (load-limit (configf:lookup-number *configdat* "jobtools" "max-server-start-load" default: 3.0)))
- ;; we want the remote server to start in *toppath* so push there
- (push-directory areapath)
- (debug:print 0 *default-log-port* "INFO: Trying to start server (" cmdln ") ...")
- (thread-start! log-rotate)
-
- ;; host.domain.tld match host?
- ;; (if (and target-host
- ;; ;; look at target host, is it host.domain.tld or ip address and does it
- ;; ;; match current ip or hostname
- ;; (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host))
- ;; (not (equal? curr-ip target-host)))
- ;; (begin
- ;; (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile)
- ;; (setenv "TARGETHOST" target-host)))
- ;;
- (setenv "TARGETHOST_LOGF" logfile)
- (thread-sleep! (/ (random 3000) 1000)) ;; add a random initial delay. It seems pretty common that many running tests request a server at the same time
- (debug:print 0 *default-log-port* "INFO: starting server at " (common:human-time))
- (system (conc "nbfake " cmdln))
- (unsetenv "TARGETHOST_LOGF")
- ;; (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST"))
- (thread-join! log-rotate)
- (pop-directory)))
-
-;; given a path to a server log return: host port startseconds server-id
-;; any changes to number of elements returned by this fuction will dirctly affect server:record->url,server:record->id,server:kill,server:get-num-alive which use match let
-;; example of what it's looking for in the log file:
-;; SERVER STARTED: 10.38.175.67:50216 AT 1616502350.0 server-id: 4907e90fc55c7a09694e3f658c639cf4
-
-(define (server:logf-get-start-info logf)
- (let ((server-rx (regexp "^SERVER STARTED: (\\S+):(\\d+) AT ([\\d\\.]+) server-id: (\\S+) pid: (\\d+)")) ;; SERVER STARTED: host:port AT timesecs server id
- (dbprep-rx (regexp "^SERVER: dbprep"))
- (dbprep-found 0)
- (bad-dat (list #f #f #f #f #f)))
- (handle-exceptions
- exn
- (begin
- ;; WARNING: this is potentially dangerous to blanket ignore the errors
- (if (file-exists? logf)
- (debug:print-info 2 *default-log-port* "Unable to get server info from "logf", exn=" exn))
- bad-dat) ;; no idea what went wrong, call it a bad server
- (with-input-from-file
- logf
- (lambda ()
- (let loop ((inl (read-line))
- (lnum 0))
- (if (not (eof-object? inl))
- (let ((mlst (string-match server-rx inl))
- (dbprep (string-match dbprep-rx inl)))
- (if dbprep (set! dbprep-found 1))
- (if (not mlst)
- (if (< lnum 500) ;; give up if more than 500 lines of server log read
- (loop (read-line)(+ lnum 1))
- (begin
- (debug:print-info 0 *default-log-port* "Unable to get server info from first 500 lines of " logf )
- bad-dat))
- (match mlst
- ((_ host port start server-id pid)
- (list host
- (string->number port)
- (string->number start)
- server-id
- (string->number pid)))
- (else
- (debug:print 0 *current-log-port* "ERROR: did not recognise SERVER line info "mlst)
- bad-dat))))
- (begin
- (if dbprep-found
- (begin
- (debug:print-info 2 *default-log-port* "Server is in dbprep at " (common:human-time))
- (thread-sleep! 0.5)) ;; was 25 sec but that blocked things from starting?
- (debug:print-info 0 *default-log-port* "Unable to get server info from " logf " at " (seconds->time-string (current-seconds))))
- bad-dat))))))))
-
-;; ;; get a list of servers from the log files, with all relevant data
-;; ;; ( mod-time host port start-time pid )
-;; ;;
-;; (define (server:get-list areapath #!key (limit #f))
-;; (let ((fname-rx (regexp "^(|.*/)server-(\\d+)-(\\S+).log$"))
-;; (day-seconds (* 24 60 60)))
-;; ;; if the directory exists continue to get the list
-;; ;; otherwise attempt to create the logs dir and then
-;; ;; continue
-;; (if (if (directory-exists? (conc areapath "/logs"))
-;; '()
-;; (if (file-write-access? areapath)
-;; (begin
-;; (condition-case
-;; (create-directory (conc areapath "/logs") #t)
-;; (exn (i/o file)(debug:print 0 *default-log-port* "ERROR: Cannot create directory at " (conc areapath "/logs")))
-;; (exn ()(debug:print 0 *default-log-port* "ERROR: Unknown error attemtping to get server list. exn=" exn)))
-;; (directory-exists? (conc areapath "/logs")))
-;; '()))
-;;
-;; ;; Get the list of server logs.
-;; (let* (
-;; ;; For some reason, when I uncomment the below line, ext-tests sometimes starts 1000's of servers.
-;; ;; (exiting-servers (system (conc "bash -c 'rm -f `grep -il exiting " areapath "/logs/server-*-*.log 2> /dev/null`'")))
-;; (server-logs (glob (conc areapath "/logs/server-*-*.log")))
-;; (num-serv-logs (length server-logs)))
-;; (if (or (null? server-logs) (= num-serv-logs 0))
-;; (let ()
-;; (debug:print 2 *default-log-port* "There are no servers running at " (common:human-time))
-;; '()
-;; )
-;; (let loop ((hed (string-chomp (car server-logs)))
-;; (tal (cdr server-logs))
-;; (res '()))
-;; (let* ((mod-time (handle-exceptions
-;; exn
-;; (begin
-;; (debug:print 0 *default-log-port* "server:get-list: failed to get modification time on " hed ", exn=" exn)
-;; (current-seconds)) ;; 0
-;; (file-modification-time hed))) ;; default to *very* old so log gets ignored if deleted
-;; (down-time (- (current-seconds) mod-time))
-;; (serv-dat (if (or (< num-serv-logs 10)
-;; (< down-time 900)) ;; day-seconds))
-;; (server:logf-get-start-info hed)
-;; '())) ;; don't waste time processing server files not touched in the 15 minutes if there are more than ten servers to look at
-;; (serv-rec (cons mod-time serv-dat))
-;; (fmatch (string-match fname-rx hed))
-;; (pid (if fmatch (string->number (list-ref fmatch 2)) #f))
-;; (new-res (if (null? serv-dat)
-;; res
-;; (cons (append serv-rec (list pid)) res)))) ;; any changes to number of elements in new-res will dirctly affect server:record->url,server:record->id,server:kill,server:get-num-alive which uses match let
-;; (if (null? tal)
-;; (if (and limit
-;; (> (length new-res) limit))
-;; new-res ;; (take new-res limit) <= need intelligent sorting before this will work
-;; new-res)
-;; (loop (string-chomp (car tal)) (cdr tal) new-res)))))))))
-
-#;(define (server:get-num-alive srvlst)
- (let ((num-alive 0))
- (for-each
- (lambda (server)
- (handle-exceptions
- exn
- (begin
- (debug:print-info 0 *default-log-port* "Unable to get server start-time and/or mod-time from " server ", exn=" exn))
- (match-let (((mod-time host port start-time server-id pid)
- server))
- (let* ((uptime (- (current-seconds) mod-time))
- (runtime (if start-time
- (- mod-time start-time)
- 0)))
- (if (< uptime 5)(set! num-alive (+ num-alive 1)))))))
- srvlst)
- num-alive))
-
-;; ;; given a list of servers get a list of valid servers, i.e. at least
-;; ;; 10 seconds old, has started and is less than 1 hour old and is
-;; ;; active (i.e. mod-time < 10 seconds
-;; ;;
-;; ;; mod-time host port start-time pid
-;; ;;
-;; ;; sort by start-time descending. I.e. get the oldest first. Young servers will thus drop off
-;; ;; and servers should stick around for about two hours or so.
-;; ;;
-;; (define (server:get-best srvlst)
-;; (let* ((nums (server:get-num-servers))
-;; (now (current-seconds))
-;; (slst (sort
-;; (filter (lambda (rec)
-;; (if (and (list? rec)
-;; (> (length rec) 2))
-;; (let ((start-time (list-ref rec 3))
-;; (mod-time (list-ref rec 0)))
-;; ;; (print "start-time: " start-time " mod-time: " mod-time)
-;; (and start-time mod-time
-;; (> (- now start-time) 0) ;; been running at least 0 seconds
-;; (< (- now mod-time) 16) ;; still alive - file touched in last 16 seconds
-;; (or (not (configf:lookup *configdat* "server" "runtime")) ;; skip if not set
-;; (< (- now start-time)
-;; (+ (- (string->number (configf:lookup *configdat* "server" "runtime"))
-;; 180)
-;; (random 360)))) ;; under one hour running time +/- 180
-;; ))
-;; #f))
-;; srvlst)
-;; (lambda (a b)
-;; (< (list-ref a 3)
-;; (list-ref b 3))))))
-;; (if (> (length slst) nums)
-;; (take slst nums)
-;; slst)))
-
-;; ;; switch from server:get-list to server:get-servers-info
-;; ;;
-;; (define (server:get-first-best areapath)
-;; (let ((srvrs (server:get-best (server:get-list areapath))))
-;; (if (and srvrs
-;; (not (null? srvrs)))
-;; (car srvrs)
-;; #f)))
-;;
-;; (define (server:get-rand-best areapath)
-;; (let ((srvrs (server:get-best (server:get-list areapath))))
-;; (if (and (list? srvrs)
-;; (not (null? srvrs)))
-;; (let* ((len (length srvrs))
-;; (idx (random len)))
-;; (list-ref srvrs idx))
-;; #f)))
-
-(define (server:record->id servr)
- (handle-exceptions
- exn
- (begin
- (debug:print-info 0 *default-log-port* "Unable to get server id from " servr ", exn=" exn)
- #f)
- (match-let (((host port start-time server-id pid)
- servr))
- (if server-id
- server-id
- #f))))
-
-(define (server:record->url servr)
- (handle-exceptions
- exn
- (begin
- (debug:print-info 0 *default-log-port* "Unable to get server url from " servr ", exn=" exn)
- #f)
- (match-let (((host port start-time server-id pid)
- servr))
- (if (and host port)
- (conc host ":" port)
- #f))))
-
-
-;; if server-start-last exists, and wasn't old enough, wait + 1, then call this function recursively until it is old enough.
-;; if it is old enough, overwrite it and wait 0.25 seconds.
-;; if it then has the wrong server key, wait + 1 and call this function recursively.
-;;
-#;(define (server:wait-for-server-start-last-flag areapath)
- (let* ((start-flag (conc areapath "/logs/server-start-last"))
- ;;; THIS INTERACTS WITH [server] timeout. Suggest using 0.1 or above for timeout (6 seconds)
- (idletime (configf:lookup-number *configdat* "server" "idletime" default: 4))
- (server-key (conc (get-host-name) "-" (current-process-id))))
- (if (file-exists? start-flag)
- (let* ((fmodtime (file-modification-time start-flag))
- (delta (- (current-seconds) fmodtime))
- (old-enough (> delta idletime))
- (new-server-key ""))
- ;; write start-flag file, wait 0.25s, then if previously the start-flag file was older than seconds, and the new file still has the same server key as you just wrote, return #t.
- ;; the intention is to make sure nfs can read the file we just wrote, and make sure it was written by us, and not another process.
- (if (and old-enough
- (begin
- (debug:print-info 2 *default-log-port* "Writing " start-flag)
- (with-output-to-file start-flag (lambda () (print server-key)))
- (thread-sleep! 0.25)
- (set! new-server-key (with-input-from-file start-flag (lambda () (read-line))))
- (equal? server-key new-server-key)))
- #t
- ;; If either of the above conditions is not true, print a "Gating server start" message, wait + 1, then call this function recursively.
- (begin
- (debug:print-info 0 *default-log-port* "Gating server start, last start: "
- (seconds->time-string fmodtime) ", time since last start: " delta ", required idletime: " idletime ", gating reason:" (if old-enough "another job started a server" "too soon to start another server"))
-
- (thread-sleep! ( + 1 idletime))
- (server:wait-for-server-start-last-flag areapath)))))))
-
-;; oldest server alive determines host then choose random of youngest
-;; five servers on that host
-;;
-(define (server:get-servers-info areapath)
- ;; (assert *toppath* "FATAL: server:get-servers-info called before *toppath* has been set.")
- (let* ((servinfodir (server:get-servinfo-dir areapath))) ;; (conc *toppath*"/.servinfo")))
- (if (not (file-exists? servinfodir))
- (create-directory servinfodir))
- (let* ((allfiles (glob (conc servinfodir"/*")))
- (res (make-hash-table)))
- (for-each
- (lambda (f)
- (let* ((hostport (pathname-strip-directory f))
- (serverdat (server:logf-get-start-info f)))
- (match serverdat
- ((host port start server-id pid)
- (if (and host port start server-id pid)
- (hash-table-set! res hostport serverdat)
- (debug:print-info 2 *default-log-port* "bad server info for "f": "serverdat)))
- (else
- (debug:print-info 2 *default-log-port* "bad server info for "f": "serverdat)))))
- allfiles)
- res)))
-
-;; check the .servinfo directory, are there other servers running on this
-;; or another host?
-;;
-;; returns #t => ok to start another server
-;; #f => not ok to start another server
-;;
-(define (server:minimal-check areapath)
- (server:clean-up-old areapath)
- (let* ((srvdir (server:get-servinfo-dir areapath)) ;; (conc areapath"/.servinfo"))
- (servrs (glob (conc srvdir"/*")))
- (thishostip (server:get-best-guess-address (get-host-name)))
- (thisservrs (glob (conc srvdir"/"thishostip":*")))
- (homehostinf (server:choose-server areapath 'homehost))
- (havehome (car homehostinf))
- (wearehome (cdr homehostinf)))
- (debug:print-info 0 *default-log-port* thishostip", have homehost: "havehome", we are homehost: "wearehome
- ", numservers: "(length thisservrs))
- (cond
- ((not havehome) #t) ;; no homehost yet, go for it
- ((and havehome wearehome (< (length thisservrs) 20)) #t) ;; we are home and less than 20 servers, ok to start another
- ((and havehome (not wearehome)) #f) ;; we are not the home host
- ((and havehome wearehome (>= (length thisservrs) 20)) #f) ;; have enough running
- (else
- (debug:print 0 *default-log-port* "WARNING: Unrecognised scenario, servrs="servrs", thishostip="thishostip", thisservrs="thisservrs)
- #t))))
-
-
-(define server-last-start 0)
-
-
-;; oldest server alive determines host then choose random of youngest
-;; five servers on that host
-;;
-;; mode:
-;; best - get best server (random of newest five)
-;; home - get home host based on oldest server
-;; info - print info
-(define (server:choose-server areapath #!optional (mode 'best))
- ;; age is current-starttime
- ;; find oldest alive
- ;; 1. sort by age ascending and ping until good
- ;; find alive rand from youngest
- ;; 1. sort by age descending
- ;; 2. take five
- ;; 3. check alive, discard if not and repeat
- ;; first we clean up old server files
- (server:clean-up-old areapath)
- (let* ((since-last (- (current-seconds) server-last-start))
- (server-start-delay 10))
- (if ( < (- (current-seconds) server-last-start) 10 )
- (begin
- (debug:print 2 *default-log-port* "server:choose-server: seconds since last server start: " (- (current-seconds) server-last-start))
- (debug:print 2 *default-log-port* "server:choose-server: last server start less than " server-start-delay " seconds ago. Sleeping " server-start-delay " seconds")
- (thread-sleep! server-start-delay)
- )
- (debug:print 2 *default-log-port* "server:choose-server: seconds since last server start: " (- (current-seconds) server-last-start))
- )
- )
- (let* ((serversdat (server:get-servers-info areapath))
- (servkeys (hash-table-keys serversdat))
- (by-time-asc (if (not (null? servkeys)) ;; NOTE: Oldest is last
- (sort servkeys ;; list of "host:port"
- (lambda (a b)
- (>= (list-ref (hash-table-ref serversdat a) 2)
- (list-ref (hash-table-ref serversdat b) 2))))
- '())))
- (debug:print 2 *default-log-port* "server:choose-server: serversdat: " serversdat)
- (debug:print 2 *default-log-port* "server:choose-server: servkeys: " servkeys)
- (if (not (null? by-time-asc))
- (let* ((oldest (last by-time-asc))
- (oldest-dat (hash-table-ref serversdat oldest))
- (host (list-ref oldest-dat 0))
- (all-valid (filter (lambda (x)
- (equal? host (list-ref (hash-table-ref serversdat x) 0)))
- by-time-asc))
- (best-ten (lambda ()
- (if (> (length all-valid) 11)
- (take (drop-right all-valid 1) 10) ;; remove the oldest from consideration so it can age out
- (if (> (length all-valid) 8)
- (drop-right all-valid 1)
- all-valid))))
- (names->dats (lambda (names)
- (map (lambda (x)
- (hash-table-ref serversdat x))
- names)))
- (am-home? (lambda ()
- (let* ((currhost (get-host-name))
- (bestadrs (server:get-best-guess-address currhost)))
- (or (equal? host currhost)
- (equal? host bestadrs))))))
- (case mode
- ((info)
- (print "oldest: "oldest-dat", selected host: "host", all-valid: "all-valid)
- (print "youngest: "(hash-table-ref serversdat (car all-valid))))
- ((home) host)
- ((homehost) (cons host (am-home?))) ;; shut up old code
- ((home?) (am-home?))
- ((best-ten)(names->dats (best-ten)))
- ((all-valid)(names->dats all-valid))
- ((best) (let* ((best-ten (best-ten))
- (len (length best-ten)))
- (hash-table-ref serversdat (list-ref best-ten (random len)))))
- ((count)(length all-valid))
- (else
- (debug:print 0 *default-log-port* "ERROR: invalid command "mode)
- #f)))
- (begin
- (server:run areapath)
- (set! server-last-start (current-seconds))
- ;; (thread-sleep! 3)
- (case mode
- ((homehost) (cons #f #f))
- (else #f))))))
-
-(define (server:get-servinfo-dir areapath)
- (let* ((spath (conc areapath"/.servinfo")))
- (if (not (file-exists? spath))
- (create-directory spath #t))
- spath))
-
-(define (server:clean-up-old areapath)
- ;; any server file that has not been touched in ten minutes is effectively dead
- (let* ((sfiles (glob (conc (server:get-servinfo-dir areapath)"/*"))))
- (for-each
- (lambda (sfile)
- (let* ((modtime (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "WARNING: failed to get modification file for "sfile)
- (current-seconds))
- (file-modification-time sfile))))
- (if (and (number? modtime)
- (> (- (current-seconds) modtime)
- 600))
- (begin
- (debug:print 0 *default-log-port* "WARNING: found old server info file "sfile", removing it.")
- (handle-exceptions
- exn
- (debug:print 0 *default-log-port* "WARNING: failed to delete old server info file "sfile)
- (delete-file sfile))))))
- sfiles)))
-
-;; would like to eventually get rid of this
-;;
-(define (common:on-homehost?)
- (server:choose-server *toppath* 'home?))
-
-;; kind start up of server, wait before allowing another server for a given
-;; area to be launched
-;;
-(define (server:kind-run areapath)
- ;; look for $MT_RUN_AREA_HOME/logs/server-start-last
- ;; and wait for it to be at least seconds old
- ;; (server:wait-for-server-start-last-flag areapath)
- (let loop ()
- (if (> (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f)) 2)
- (begin
- (if (common:low-noise-print 30 "our-host-load")
- (debug:print 0 *default-log-port* "WARNING: system load is high, waiting to start server."))
- (loop))))
- (if (< (server:choose-server areapath 'count) 20)
- (server:run areapath))
- #;(if (not (server:check-if-running areapath)) ;; why try if there is already a server running?
- (let* ((lock-file (conc areapath "/logs/server-start.lock")))
- (let* ((start-flag (conc areapath "/logs/server-start-last")))
- (common:simple-file-lock-and-wait lock-file expire-time: 25)
- (debug:print-info 2 *default-log-port* "server:kind-run: touching " start-flag)
- (system (conc "touch " start-flag)) ;; lazy but safe
- (server:run areapath)
- (thread-sleep! 20) ;; don't release the lock for at least a few seconds. And allow time for the server startup to get to "SERVER STARTED".
- (common:simple-file-release-lock lock-file)))
- (debug:print-info 0 *default-log-port* "Found server already running. NOT trying to start another.")))
-
-;; this one seems to be the general entry point
-;;
-(define (server:start-and-wait areapath #!key (timeout 60))
- (let ((give-up-time (+ (current-seconds) timeout)))
- (let loop ((server-info (server:check-if-running areapath))
- (try-num 0))
- (if (or server-info
- (> (current-seconds) give-up-time)) ;; server-url will be #f if no server available.
- (server:record->url server-info)
- (let* ( (servers (server:choose-server areapath 'all-valid))
- (num-ok (if servers (length (server:choose-server areapath 'all-valid)) 0)))
- (if (and (> try-num 0) ;; first time through simply wait a little while then try again
- (< num-ok 1)) ;; if there are no decent candidates for servers then try starting a new one
- (server:run areapath))
- (thread-sleep! 5)
- (loop (server:check-if-running areapath)
- (+ try-num 1)))))))
-
-(define (server:get-num-servers #!key (numservers 2))
- (let ((ns (string->number
- (or (configf:lookup *configdat* "server" "numservers") "notanumber"))))
- (or ns numservers)))
-
-;; no longer care if multiple servers are started by accident. older servers will drop off in time.
-;;
-(define (server:check-if-running areapath) ;; #!key (numservers "2"))
- (let* ((ns (server:get-num-servers)) ;; get the setting the for maximum number of servers allowed
- (servers (server:choose-server areapath 'best-ten))) ;; (server:get-best (server:get-list areapath))))
- (if (or (and servers
- (null? servers))
- (not servers))
- ;; (and (list? servers)
- ;; (< (length servers) (+ 1 (random ns))))) ;; somewhere between 1 and numservers
- #f
- (let loop ((hed (car servers))
- (tal (cdr servers)))
- (let ((res (server:check-server hed)))
- (if res
- hed
- (if (null? tal)
- #f
- (loop (car tal)(cdr tal)))))))))
-
-;; ping the given server
-;;
-(define (server:check-server server-record)
- (let* ((server-url (server:record->url server-record))
- (server-id (server:record->id server-record))
- (res (server:ping server-url server-id)))
- (if res
- server-url
- #f)))
-
-(define (server:kill servr)
- (handle-exceptions
- exn
- (begin
- (debug:print-info 0 *default-log-port* "Unable to get host and/or port from " servr ", exn=" exn)
- #f)
- (match-let (((mod-time hostname port start-time server-id pid)
- servr))
- (tasks:kill-server hostname pid))))
-
-;; called in megatest.scm, host-port is string hostname:port
-;;
-;; NOTE: This is NOT called directly from clients as not all transports support a client running
-;; in the same process as the server.
-;;
-(define (server:ping host:port server-id #!key (do-exit #f))
- (let* ((host-port (cond
- ((string? host:port)
- (let ((slst (string-split host:port ":")))
- (if (eq? (length slst) 2)
- (list (car slst)(string->number (cadr slst)))
- #f)))
- (else
- #f))))
- (cond
- ((and (list? host-port)
- (eq? (length host-port) 2))
- (let* ((myrunremote (make-remote))
- (iface (car host-port))
- (port (cadr host-port))
- (server-dat (client:connect iface port server-id myrunremote))
- (login-res (rmt:login-no-auto-client-setup myrunremote)))
- (if (and (list? login-res)
- (car login-res))
- (begin
- ;; (print "LOGIN_OK")
- (if do-exit (exit 0))
- #t)
- (begin
- ;; (print "LOGIN_FAILED")
- (if do-exit (exit 1))
- #f))))
- (else
- (if host:port
- (debug:print 0 *default-log-port* "ERROR: bad host:port "host:port))
- (if do-exit
- (exit 1)
- #f)))))
-
-;; run ping in separate process, safest way in some cases
-;;
-(define (server:ping-server ifaceport)
- (with-input-from-pipe
- (conc (common:get-megatest-exe) " -ping " ifaceport)
- (lambda ()
- (let loop ((inl (read-line))
- (res "NOREPLY"))
- (if (eof-object? inl)
- (case (string->symbol res)
- ((NOREPLY) #f)
- ((LOGIN_OK) #t)
- (else #f))
- (loop (read-line) inl))))))
-
-;; NOT USED (well, ok, reference in rpc-transport but otherwise not used).
-;;
-(define (server:login toppath)
- (lambda (toppath)
- (set! *db-last-access* (current-seconds)) ;; might not be needed.
- (if (equal? *toppath* toppath)
- #t
- #f)))
-
-;; timeout is hms string: 1h 5m 3s, default is 1 minute
-;; This is currently broken. Just use the number of hours with no unit.
-;; Default is 60 seconds.
-;;
-(define (server:expiration-timeout)
- (let ((tmo (configf:lookup *configdat* "server" "timeout")))
- (if (and (string? tmo)
- (common:hms-string->seconds tmo)) ;; BUG: hms-string->seconds is broken, if given "10" returns 0. Also, it doesn't belong in this logic unless the string->number is changed below
- (* 3600 (string->number tmo))
- 600)))
-
-(define (server:get-best-guess-address hostname)
- (let ((res #f))
- (for-each
- (lambda (adr)
- (if (not (eq? (u8vector-ref adr 0) 127))
- (set! res adr)))
- ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME
- (vector->list (hostinfo-addresses (hostname->hostinfo hostname))))
- (string-intersperse
- (map number->string
- (u8vector->list
- (if res res (hostname->ip hostname)))) ".")))
-
-;; (define server:sync-lock-token "SERVER_SYNC_LOCK")
-;; (define (server:release-sync-lock)
-;; (db:no-sync-del! *no-sync-db* server:sync-lock-token))
-;; (define (server:have-sync-lock?)
-;; (let* ((have-lock-pair (db:no-sync-get-lock *no-sync-db* server:sync-lock-token))
-;; (have-lock? (car have-lock-pair))
-;; (lock-time (cdr have-lock-pair))
-;; (lock-age (- (current-seconds) lock-time)))
-;; (cond
-;; (have-lock? #t)
-;; ((>lock-age
-;; (* 3 (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 180)))
-;; (server:release-sync-lock)
-;; (server:have-sync-lock?))
-;; (else #f))))
-
-;; moving this here as it needs access to db and cannot be in common.
-;;
-
-(define (server:get-bruteforce-syncer dbstruct #!key (fork-to-background #f) (persist-until-sync #f))
- (debug:print "WARNING: bruteforce-syncer is called but has been disabled!")
- (lambda ()
- (debug:print "WARNING: bruteforce-syncer is called but has been disabled!"))
- #;(let* ((sqlite-exe (or (get-environment-variable "MT_SQLITE3_EXE"))) ;; defined in cfg.sh
- (sync-log (or (args:get-arg "-sync-log") (conc *toppath* "/logs/sync-" (current-process-id) "-" (get-host-name) ".log")))
- (tmp-area (common:get-db-tmp-area))
- (tmp-db (conc tmp-area "/megatest.db"))
- (staging-file (conc *toppath* "/.megatest.db"))
- (mtdbfile (conc *toppath* "/megatest.db"))
- (lockfile (common:get-sync-lock-filepath))
- (sync-cmd-core (conc sqlite-exe" " tmp-db " .dump | "sqlite-exe" " staging-file "&>"sync-log))
- (sync-cmd (if fork-to-background
- (conc "/usr/bin/env NBFAKE_LOG="*toppath*"/logs/last-server-sync-"(current-process-id)".log nbfake \""sync-cmd-core" && /bin/mv -f " staging-file " " mtdbfile" \"")
- sync-cmd-core))
- (default-min-intersync-delay 2)
- (min-intersync-delay (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: default-min-intersync-delay))
- (default-duty-cycle 0.1)
- (duty-cycle (configf:lookup-number *configdat* "server" "sync-duty-cycle" default: default-duty-cycle))
- (last-sync-seconds 10) ;; we will adjust this to a measurement and delay last-sync-seconds * (1 - duty-cycle)
- (calculate-off-time (lambda (work-duration duty-cycle)
- (* (/ (- 1 duty-cycle) duty-cycle) last-sync-seconds)))
- (off-time min-intersync-delay) ;; adjusted in closure below.
- (do-a-sync
- (lambda ()
- (BB> "Start do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync)
- (let* ((finalres
- (let retry-loop ((num-tries 0))
- (if (common:simple-file-lock lockfile)
- (begin
- (cond
- ((not (or fork-to-background persist-until-sync))
- (debug:print 0 *default-log-port* "INFO: syncer thread sleeping for max of (server.minimum-intersync-delay="min-intersync-delay
- " , off-time="off-time" seconds ]")
- (thread-sleep! (max off-time min-intersync-delay)))
- (else
- (debug:print 0 *default-log-port* "INFO: syncer thread NOT sleeping ; maybe time-to-exit...")))
-
- (if (not (configf:lookup *configdat* "server" "disable-db-snapshot"))
- (common:snapshot-file mtdbfile subdir: ".db-snapshot"))
- (delete-file* staging-file)
- (let* ((start-time (current-milliseconds))
- (res (system sync-cmd))
- (dbbackupfile (conc mtdbfile ".backup"))
- (res2
- (cond
- ((eq? 0 res )
- (handle-exceptions
- exn
- #f
- (if (file-exists? dbbackupfile)
- (delete-file* dbbackupfile)
- )
- (if (eq? 0 (file-size sync-log))
- (delete-file* sync-log))
- (system (conc "/bin/mv " staging-file " " mtdbfile))
-
- (set! last-sync-seconds (/ (- (current-milliseconds) start-time) 1000))
- (set! off-time (calculate-off-time
- last-sync-seconds
- (cond
- ((and (number? duty-cycle) (> duty-cycle 0) (< duty-cycle 1))
- duty-cycle)
- (else
- (debug:print 0 *default-log-port* "WARNING: ["(common:human-time)"] server.sync-duty-cycle is invalid. Should be a number between 0 and 1, but "duty-cycle" was specified. Using default value: "default-duty-cycle)
- default-duty-cycle))))
-
- (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" SYNC took "last-sync-seconds" sec")
- (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" SYNC took "last-sync-seconds" sec ; with duty-cycle of "duty-cycle" off time is now "off-time)
- 'sync-completed))
- (else
- (system (conc "/bin/cp "sync-log" "sync-log".fail"))
- (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Sync failed. See log at "sync-log".fail")
- (if (file-exists? (conc mtdbfile ".backup"))
- (system (conc "/bin/cp "mtdbfile ".backup " mtdbfile)))
- #f))))
- (common:simple-file-release-lock lockfile)
- (BB> "released lockfile: " lockfile)
- (when (common:file-exists? lockfile)
- (BB> "DID NOT ACTUALLY RELEASE LOCKFILE"))
- res2) ;; end let
- );; end begin
- ;; else
- (cond
- (persist-until-sync
- (thread-sleep! 1)
- (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; we're in a fork-to-background so we need to succeed. Let's wait a jiffy and and try again. num-tries="num-tries" (waiting for lockfile="lockfile" to disappear)")
- (retry-loop (add1 num-tries)))
- (else
- (thread-sleep! (max off-time (+ last-sync-seconds min-intersync-delay)))
- (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; not syncing.")
- 'parallel-sync-in-progress))
- ) ;; end if got lockfile
- )
- ))
- (BB> "End do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync" and result="finalres)
- finalres)
- ) ;; end lambda
- ))
- do-a-sync))
-
+;; (require-extension (srfi 18) extras tcp s11n)
+;;
+;; (use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest
+;; directory-utils posix-extras matchable utils)
+;;
+;; (use spiffy uri-common intarweb http-client spiffy-request-vars)
+;;
+;; (declare (unit server))
+;;
+;; (declare (uses commonmod))
+;;
+;; (declare (uses common))
+;; (declare (uses db))
+;; (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
+;; ;; (declare (uses synchash))
+;; (declare (uses http-transport))
+;; ;;(declare (uses rpc-transport))
+;; (declare (uses launch))
+;; ;; (declare (uses daemon))
+;;
+;; (import commonmod)
+;;
+;; (include "common_records.scm")
+;; (include "db_records.scm")
+;;
+;; (define (server:make-server-url hostport)
+;; (if (not hostport)
+;; #f
+;; (conc "http://" (car hostport) ":" (cadr hostport))))
+;;
+;; (define *server-loop-heart-beat* (current-seconds))
+;;
+;; ;;======================================================================
+;; ;; P K T S S T U F F
+;; ;;======================================================================
+;;
+;; ;; ???
+;;
+;; ;;======================================================================
+;; ;; P K T S S T U F F
+;; ;;======================================================================
+;;
+;; ;; ???
+;;
+;; ;;======================================================================
+;; ;; S E R V E R
+;; ;;======================================================================
+;;
+;; ;; Call this to start the actual server
+;; ;;
+;;
+;; ;;======================================================================
+;; ;; S E R V E R U T I L I T I E S
+;; ;;======================================================================
+;;
+;; ;; Get the transport
+;; (define (server:get-transport)
+;; (if *transport-type*
+;; *transport-type*
+;; (let ((ttype (string->symbol
+;; (or (args:get-arg "-transport")
+;; (configf:lookup *configdat* "server" "transport")
+;; "rpc"))))
+;; (set! *transport-type* ttype)
+;; ttype)))
+;;
+;; ;; Generate a unique signature for this server
+;; (define (server:mk-signature)
+;; (message-digest-string (md5-primitive)
+;; (with-output-to-string
+;; (lambda ()
+;; (write (list (current-directory)
+;; (current-process-id)
+;; (argv)))))))
+;;
+;; (define (server:get-client-signature)
+;; (if *my-client-signature* *my-client-signature*
+;; (let ((sig (server:mk-signature))) ;; clients re-use the server:mk-signature logic
+;; (set! *my-client-signature* sig)
+;; *my-client-signature*)))
+;;
+;; (define (server:get-server-id)
+;; (if *server-id* *server-id*
+;; (let ((sig (server:mk-signature))) ;; clients re-use the server:mk-signature logic
+;; (set! *server-id* sig)
+;; *server-id*)))
+;;
+;; ;; When using zmq this would send the message back (two step process)
+;; ;; with spiffy or rpc this simply returns the return data to be returned
+;; ;;
+;; (define (server:reply return-addr query-sig success/fail result)
+;; (debug:print-info 11 *default-log-port* "server:reply return-addr=" return-addr ", result=" result)
+;; ;; (send-message pubsock target send-more: #t)
+;; ;; (send-message pubsock
+;; (case (server:get-transport)
+;; ((rpc) (db:obj->string (vector success/fail query-sig result)))
+;; ((http) (db:obj->string (vector success/fail query-sig result)))
+;; ((fs) result)
+;; (else
+;; (debug:print-error 0 *default-log-port* "unrecognised transport type: " *transport-type*)
+;; result)))
+;;
+;; ;; Given an area path, start a server process ### NOTE ### > file 2>&1
+;; ;; if the target-host is set
+;; ;; try running on that host
+;; ;; incidental: rotate logs in logs/ dir.
+;; ;;
+;; (define (server:run areapath) ;; areapath is *toppath* for a given testsuite area
+;; (let* ((testsuite (common:get-testsuite-name))
+;; (logfile (conc areapath "/logs/server.log")) ;; -" curr-pid "-" target-host ".log"))
+;; (profile-mode (or (configf:lookup *configdat* "misc" "profilesw")
+;; ""))
+;; (cmdln (conc (common:get-megatest-exe)
+;; " -server - ";; (or target-host "-")
+;; (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
+;; " -daemonize "
+;; "")
+;; ;; " -log " logfile
+;; " -m testsuite:" testsuite
+;; " " profile-mode
+;; )) ;; (conc " >> " logfile " 2>&1 &")))))
+;; (log-rotate (make-thread common:rotate-logs "server run, rotate logs thread")) ;; why are we rotating logs here? This is a sensitive location with a lot going on!?
+;; (load-limit (configf:lookup-number *configdat* "jobtools" "max-server-start-load" default: 3.0)))
+;; ;; we want the remote server to start in *toppath* so push there
+;; (push-directory areapath)
+;; (debug:print 0 *default-log-port* "INFO: Trying to start server (" cmdln ") ...")
+;; (thread-start! log-rotate)
+;;
+;; ;; host.domain.tld match host?
+;; ;; (if (and target-host
+;; ;; ;; look at target host, is it host.domain.tld or ip address and does it
+;; ;; ;; match current ip or hostname
+;; ;; (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host))
+;; ;; (not (equal? curr-ip target-host)))
+;; ;; (begin
+;; ;; (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile)
+;; ;; (setenv "TARGETHOST" target-host)))
+;; ;;
+;; (setenv "TARGETHOST_LOGF" logfile)
+;; (thread-sleep! (/ (random 3000) 1000)) ;; add a random initial delay. It seems pretty common that many running tests request a server at the same time
+;; (debug:print 0 *default-log-port* "INFO: starting server at " (common:human-time))
+;; (system (conc "nbfake " cmdln))
+;; (unsetenv "TARGETHOST_LOGF")
+;; ;; (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST"))
+;; (thread-join! log-rotate)
+;; (pop-directory)))
+;;
+;; ;; given a path to a server log return: host port startseconds server-id
+;; ;; any changes to number of elements returned by this fuction will dirctly affect server:record->url,server:record->id,server:kill,server:get-num-alive which use match let
+;; ;; example of what it's looking for in the log file:
+;; ;; SERVER STARTED: 10.38.175.67:50216 AT 1616502350.0 server-id: 4907e90fc55c7a09694e3f658c639cf4
+;;
+;; (define (server:logf-get-start-info logf)
+;; (let ((server-rx (regexp "^SERVER STARTED: (\\S+):(\\d+) AT ([\\d\\.]+) server-id: (\\S+) pid: (\\d+)")) ;; SERVER STARTED: host:port AT timesecs server id
+;; (dbprep-rx (regexp "^SERVER: dbprep"))
+;; (dbprep-found 0)
+;; (bad-dat (list #f #f #f #f #f)))
+;; (handle-exceptions
+;; exn
+;; (begin
+;; ;; WARNING: this is potentially dangerous to blanket ignore the errors
+;; (if (file-exists? logf)
+;; (debug:print-info 2 *default-log-port* "Unable to get server info from "logf", exn=" exn))
+;; bad-dat) ;; no idea what went wrong, call it a bad server
+;; (with-input-from-file
+;; logf
+;; (lambda ()
+;; (let loop ((inl (read-line))
+;; (lnum 0))
+;; (if (not (eof-object? inl))
+;; (let ((mlst (string-match server-rx inl))
+;; (dbprep (string-match dbprep-rx inl)))
+;; (if dbprep (set! dbprep-found 1))
+;; (if (not mlst)
+;; (if (< lnum 500) ;; give up if more than 500 lines of server log read
+;; (loop (read-line)(+ lnum 1))
+;; (begin
+;; (debug:print-info 0 *default-log-port* "Unable to get server info from first 500 lines of " logf )
+;; bad-dat))
+;; (match mlst
+;; ((_ host port start server-id pid)
+;; (list host
+;; (string->number port)
+;; (string->number start)
+;; server-id
+;; (string->number pid)))
+;; (else
+;; (debug:print 0 *current-log-port* "ERROR: did not recognise SERVER line info "mlst)
+;; bad-dat))))
+;; (begin
+;; (if dbprep-found
+;; (begin
+;; (debug:print-info 2 *default-log-port* "Server is in dbprep at " (common:human-time))
+;; (thread-sleep! 0.5)) ;; was 25 sec but that blocked things from starting?
+;; (debug:print-info 0 *default-log-port* "Unable to get server info from " logf " at " (seconds->time-string (current-seconds))))
+;; bad-dat))))))))
+;;
+;; ;; ;; get a list of servers from the log files, with all relevant data
+;; ;; ;; ( mod-time host port start-time pid )
+;; ;; ;;
+;; ;; (define (server:get-list areapath #!key (limit #f))
+;; ;; (let ((fname-rx (regexp "^(|.*/)server-(\\d+)-(\\S+).log$"))
+;; ;; (day-seconds (* 24 60 60)))
+;; ;; ;; if the directory exists continue to get the list
+;; ;; ;; otherwise attempt to create the logs dir and then
+;; ;; ;; continue
+;; ;; (if (if (directory-exists? (conc areapath "/logs"))
+;; ;; '()
+;; ;; (if (file-write-access? areapath)
+;; ;; (begin
+;; ;; (condition-case
+;; ;; (create-directory (conc areapath "/logs") #t)
+;; ;; (exn (i/o file)(debug:print 0 *default-log-port* "ERROR: Cannot create directory at " (conc areapath "/logs")))
+;; ;; (exn ()(debug:print 0 *default-log-port* "ERROR: Unknown error attemtping to get server list. exn=" exn)))
+;; ;; (directory-exists? (conc areapath "/logs")))
+;; ;; '()))
+;; ;;
+;; ;; ;; Get the list of server logs.
+;; ;; (let* (
+;; ;; ;; For some reason, when I uncomment the below line, ext-tests sometimes starts 1000's of servers.
+;; ;; ;; (exiting-servers (system (conc "bash -c 'rm -f `grep -il exiting " areapath "/logs/server-*-*.log 2> /dev/null`'")))
+;; ;; (server-logs (glob (conc areapath "/logs/server-*-*.log")))
+;; ;; (num-serv-logs (length server-logs)))
+;; ;; (if (or (null? server-logs) (= num-serv-logs 0))
+;; ;; (let ()
+;; ;; (debug:print 2 *default-log-port* "There are no servers running at " (common:human-time))
+;; ;; '()
+;; ;; )
+;; ;; (let loop ((hed (string-chomp (car server-logs)))
+;; ;; (tal (cdr server-logs))
+;; ;; (res '()))
+;; ;; (let* ((mod-time (handle-exceptions
+;; ;; exn
+;; ;; (begin
+;; ;; (debug:print 0 *default-log-port* "server:get-list: failed to get modification time on " hed ", exn=" exn)
+;; ;; (current-seconds)) ;; 0
+;; ;; (file-modification-time hed))) ;; default to *very* old so log gets ignored if deleted
+;; ;; (down-time (- (current-seconds) mod-time))
+;; ;; (serv-dat (if (or (< num-serv-logs 10)
+;; ;; (< down-time 900)) ;; day-seconds))
+;; ;; (server:logf-get-start-info hed)
+;; ;; '())) ;; don't waste time processing server files not touched in the 15 minutes if there are more than ten servers to look at
+;; ;; (serv-rec (cons mod-time serv-dat))
+;; ;; (fmatch (string-match fname-rx hed))
+;; ;; (pid (if fmatch (string->number (list-ref fmatch 2)) #f))
+;; ;; (new-res (if (null? serv-dat)
+;; ;; res
+;; ;; (cons (append serv-rec (list pid)) res)))) ;; any changes to number of elements in new-res will dirctly affect server:record->url,server:record->id,server:kill,server:get-num-alive which uses match let
+;; ;; (if (null? tal)
+;; ;; (if (and limit
+;; ;; (> (length new-res) limit))
+;; ;; new-res ;; (take new-res limit) <= need intelligent sorting before this will work
+;; ;; new-res)
+;; ;; (loop (string-chomp (car tal)) (cdr tal) new-res)))))))))
+;;
+;; #;(define (server:get-num-alive srvlst)
+;; (let ((num-alive 0))
+;; (for-each
+;; (lambda (server)
+;; (handle-exceptions
+;; exn
+;; (begin
+;; (debug:print-info 0 *default-log-port* "Unable to get server start-time and/or mod-time from " server ", exn=" exn))
+;; (match-let (((mod-time host port start-time server-id pid)
+;; server))
+;; (let* ((uptime (- (current-seconds) mod-time))
+;; (runtime (if start-time
+;; (- mod-time start-time)
+;; 0)))
+;; (if (< uptime 5)(set! num-alive (+ num-alive 1)))))))
+;; srvlst)
+;; num-alive))
+;;
+;; ;; ;; given a list of servers get a list of valid servers, i.e. at least
+;; ;; ;; 10 seconds old, has started and is less than 1 hour old and is
+;; ;; ;; active (i.e. mod-time < 10 seconds
+;; ;; ;;
+;; ;; ;; mod-time host port start-time pid
+;; ;; ;;
+;; ;; ;; sort by start-time descending. I.e. get the oldest first. Young servers will thus drop off
+;; ;; ;; and servers should stick around for about two hours or so.
+;; ;; ;;
+;; ;; (define (server:get-best srvlst)
+;; ;; (let* ((nums (server:get-num-servers))
+;; ;; (now (current-seconds))
+;; ;; (slst (sort
+;; ;; (filter (lambda (rec)
+;; ;; (if (and (list? rec)
+;; ;; (> (length rec) 2))
+;; ;; (let ((start-time (list-ref rec 3))
+;; ;; (mod-time (list-ref rec 0)))
+;; ;; ;; (print "start-time: " start-time " mod-time: " mod-time)
+;; ;; (and start-time mod-time
+;; ;; (> (- now start-time) 0) ;; been running at least 0 seconds
+;; ;; (< (- now mod-time) 16) ;; still alive - file touched in last 16 seconds
+;; ;; (or (not (configf:lookup *configdat* "server" "runtime")) ;; skip if not set
+;; ;; (< (- now start-time)
+;; ;; (+ (- (string->number (configf:lookup *configdat* "server" "runtime"))
+;; ;; 180)
+;; ;; (random 360)))) ;; under one hour running time +/- 180
+;; ;; ))
+;; ;; #f))
+;; ;; srvlst)
+;; ;; (lambda (a b)
+;; ;; (< (list-ref a 3)
+;; ;; (list-ref b 3))))))
+;; ;; (if (> (length slst) nums)
+;; ;; (take slst nums)
+;; ;; slst)))
+;;
+;; ;; ;; switch from server:get-list to server:get-servers-info
+;; ;; ;;
+;; ;; (define (server:get-first-best areapath)
+;; ;; (let ((srvrs (server:get-best (server:get-list areapath))))
+;; ;; (if (and srvrs
+;; ;; (not (null? srvrs)))
+;; ;; (car srvrs)
+;; ;; #f)))
+;; ;;
+;; ;; (define (server:get-rand-best areapath)
+;; ;; (let ((srvrs (server:get-best (server:get-list areapath))))
+;; ;; (if (and (list? srvrs)
+;; ;; (not (null? srvrs)))
+;; ;; (let* ((len (length srvrs))
+;; ;; (idx (random len)))
+;; ;; (list-ref srvrs idx))
+;; ;; #f)))
+;;
+;; (define (server:record->id servr)
+;; (handle-exceptions
+;; exn
+;; (begin
+;; (debug:print-info 0 *default-log-port* "Unable to get server id from " servr ", exn=" exn)
+;; #f)
+;; (match-let (((host port start-time server-id pid)
+;; servr))
+;; (if server-id
+;; server-id
+;; #f))))
+;;
+;; (define (server:record->url servr)
+;; (handle-exceptions
+;; exn
+;; (begin
+;; (debug:print-info 0 *default-log-port* "Unable to get server url from " servr ", exn=" exn)
+;; #f)
+;; (match-let (((host port start-time server-id pid)
+;; servr))
+;; (if (and host port)
+;; (conc host ":" port)
+;; #f))))
+;;
+;;
+;; ;; if server-start-last exists, and wasn't old enough, wait + 1, then call this function recursively until it is old enough.
+;; ;; if it is old enough, overwrite it and wait 0.25 seconds.
+;; ;; if it then has the wrong server key, wait + 1 and call this function recursively.
+;; ;;
+;; #;(define (server:wait-for-server-start-last-flag areapath)
+;; (let* ((start-flag (conc areapath "/logs/server-start-last"))
+;; ;;; THIS INTERACTS WITH [server] timeout. Suggest using 0.1 or above for timeout (6 seconds)
+;; (idletime (configf:lookup-number *configdat* "server" "idletime" default: 4))
+;; (server-key (conc (get-host-name) "-" (current-process-id))))
+;; (if (file-exists? start-flag)
+;; (let* ((fmodtime (file-modification-time start-flag))
+;; (delta (- (current-seconds) fmodtime))
+;; (old-enough (> delta idletime))
+;; (new-server-key ""))
+;; ;; write start-flag file, wait 0.25s, then if previously the start-flag file was older than seconds, and the new file still has the same server key as you just wrote, return #t.
+;; ;; the intention is to make sure nfs can read the file we just wrote, and make sure it was written by us, and not another process.
+;; (if (and old-enough
+;; (begin
+;; (debug:print-info 2 *default-log-port* "Writing " start-flag)
+;; (with-output-to-file start-flag (lambda () (print server-key)))
+;; (thread-sleep! 0.25)
+;; (set! new-server-key (with-input-from-file start-flag (lambda () (read-line))))
+;; (equal? server-key new-server-key)))
+;; #t
+;; ;; If either of the above conditions is not true, print a "Gating server start" message, wait + 1, then call this function recursively.
+;; (begin
+;; (debug:print-info 0 *default-log-port* "Gating server start, last start: "
+;; (seconds->time-string fmodtime) ", time since last start: " delta ", required idletime: " idletime ", gating reason:" (if old-enough "another job started a server" "too soon to start another server"))
+;;
+;; (thread-sleep! ( + 1 idletime))
+;; (server:wait-for-server-start-last-flag areapath)))))))
+;;
+;; ;; oldest server alive determines host then choose random of youngest
+;; ;; five servers on that host
+;; ;;
+;; (define (server:get-servers-info areapath)
+;; ;; (assert *toppath* "FATAL: server:get-servers-info called before *toppath* has been set.")
+;; (let* ((servinfodir (server:get-servinfo-dir areapath))) ;; (conc *toppath*"/.servinfo")))
+;; (if (not (file-exists? servinfodir))
+;; (create-directory servinfodir))
+;; (let* ((allfiles (glob (conc servinfodir"/*")))
+;; (res (make-hash-table)))
+;; (for-each
+;; (lambda (f)
+;; (let* ((hostport (pathname-strip-directory f))
+;; (serverdat (server:logf-get-start-info f)))
+;; (match serverdat
+;; ((host port start server-id pid)
+;; (if (and host port start server-id pid)
+;; (hash-table-set! res hostport serverdat)
+;; (debug:print-info 2 *default-log-port* "bad server info for "f": "serverdat)))
+;; (else
+;; (debug:print-info 2 *default-log-port* "bad server info for "f": "serverdat)))))
+;; allfiles)
+;; res)))
+;;
+;; ;; check the .servinfo directory, are there other servers running on this
+;; ;; or another host?
+;; ;;
+;; ;; returns #t => ok to start another server
+;; ;; #f => not ok to start another server
+;; ;;
+;; (define (server:minimal-check areapath)
+;; (server:clean-up-old areapath)
+;; (let* ((srvdir (server:get-servinfo-dir areapath)) ;; (conc areapath"/.servinfo"))
+;; (servrs (glob (conc srvdir"/*")))
+;; (thishostip (server:get-best-guess-address (get-host-name)))
+;; (thisservrs (glob (conc srvdir"/"thishostip":*")))
+;; (homehostinf (server:choose-server areapath 'homehost))
+;; (havehome (car homehostinf))
+;; (wearehome (cdr homehostinf)))
+;; (debug:print-info 0 *default-log-port* thishostip", have homehost: "havehome", we are homehost: "wearehome
+;; ", numservers: "(length thisservrs))
+;; (cond
+;; ((not havehome) #t) ;; no homehost yet, go for it
+;; ((and havehome wearehome (< (length thisservrs) 20)) #t) ;; we are home and less than 20 servers, ok to start another
+;; ((and havehome (not wearehome)) #f) ;; we are not the home host
+;; ((and havehome wearehome (>= (length thisservrs) 20)) #f) ;; have enough running
+;; (else
+;; (debug:print 0 *default-log-port* "WARNING: Unrecognised scenario, servrs="servrs", thishostip="thishostip", thisservrs="thisservrs)
+;; #t))))
+;;
+;;
+;; (define server-last-start 0)
+;;
+;;
+;; ;; oldest server alive determines host then choose random of youngest
+;; ;; five servers on that host
+;; ;;
+;; ;; mode:
+;; ;; best - get best server (random of newest five)
+;; ;; home - get home host based on oldest server
+;; ;; info - print info
+;; (define (server:choose-server areapath #!optional (mode 'best))
+;; ;; age is current-starttime
+;; ;; find oldest alive
+;; ;; 1. sort by age ascending and ping until good
+;; ;; find alive rand from youngest
+;; ;; 1. sort by age descending
+;; ;; 2. take five
+;; ;; 3. check alive, discard if not and repeat
+;; ;; first we clean up old server files
+;; (server:clean-up-old areapath)
+;; (let* ((since-last (- (current-seconds) server-last-start))
+;; (server-start-delay 10))
+;; (if ( < (- (current-seconds) server-last-start) 10 )
+;; (begin
+;; (debug:print 2 *default-log-port* "server:choose-server: seconds since last server start: " (- (current-seconds) server-last-start))
+;; (debug:print 2 *default-log-port* "server:choose-server: last server start less than " server-start-delay " seconds ago. Sleeping " server-start-delay " seconds")
+;; (thread-sleep! server-start-delay)
+;; )
+;; (debug:print 2 *default-log-port* "server:choose-server: seconds since last server start: " (- (current-seconds) server-last-start))
+;; )
+;; )
+;; (let* ((serversdat (server:get-servers-info areapath))
+;; (servkeys (hash-table-keys serversdat))
+;; (by-time-asc (if (not (null? servkeys)) ;; NOTE: Oldest is last
+;; (sort servkeys ;; list of "host:port"
+;; (lambda (a b)
+;; (>= (list-ref (hash-table-ref serversdat a) 2)
+;; (list-ref (hash-table-ref serversdat b) 2))))
+;; '())))
+;; (debug:print 2 *default-log-port* "server:choose-server: serversdat: " serversdat)
+;; (debug:print 2 *default-log-port* "server:choose-server: servkeys: " servkeys)
+;; (if (not (null? by-time-asc))
+;; (let* ((oldest (last by-time-asc))
+;; (oldest-dat (hash-table-ref serversdat oldest))
+;; (host (list-ref oldest-dat 0))
+;; (all-valid (filter (lambda (x)
+;; (equal? host (list-ref (hash-table-ref serversdat x) 0)))
+;; by-time-asc))
+;; (best-ten (lambda ()
+;; (if (> (length all-valid) 11)
+;; (take (drop-right all-valid 1) 10) ;; remove the oldest from consideration so it can age out
+;; (if (> (length all-valid) 8)
+;; (drop-right all-valid 1)
+;; all-valid))))
+;; (names->dats (lambda (names)
+;; (map (lambda (x)
+;; (hash-table-ref serversdat x))
+;; names)))
+;; (am-home? (lambda ()
+;; (let* ((currhost (get-host-name))
+;; (bestadrs (server:get-best-guess-address currhost)))
+;; (or (equal? host currhost)
+;; (equal? host bestadrs))))))
+;; (case mode
+;; ((info)
+;; (print "oldest: "oldest-dat", selected host: "host", all-valid: "all-valid)
+;; (print "youngest: "(hash-table-ref serversdat (car all-valid))))
+;; ((home) host)
+;; ((homehost) (cons host (am-home?))) ;; shut up old code
+;; ((home?) (am-home?))
+;; ((best-ten)(names->dats (best-ten)))
+;; ((all-valid)(names->dats all-valid))
+;; ((best) (let* ((best-ten (best-ten))
+;; (len (length best-ten)))
+;; (hash-table-ref serversdat (list-ref best-ten (random len)))))
+;; ((count)(length all-valid))
+;; (else
+;; (debug:print 0 *default-log-port* "ERROR: invalid command "mode)
+;; #f)))
+;; (begin
+;; (server:run areapath)
+;; (set! server-last-start (current-seconds))
+;; ;; (thread-sleep! 3)
+;; (case mode
+;; ((homehost) (cons #f #f))
+;; (else #f))))))
+;;
+;; (define (server:get-servinfo-dir areapath)
+;; (let* ((spath (conc areapath"/.servinfo")))
+;; (if (not (file-exists? spath))
+;; (create-directory spath #t))
+;; spath))
+;;
+;; (define (server:clean-up-old areapath)
+;; ;; any server file that has not been touched in ten minutes is effectively dead
+;; (let* ((sfiles (glob (conc (server:get-servinfo-dir areapath)"/*"))))
+;; (for-each
+;; (lambda (sfile)
+;; (let* ((modtime (handle-exceptions
+;; exn
+;; (begin
+;; (debug:print 0 *default-log-port* "WARNING: failed to get modification file for "sfile)
+;; (current-seconds))
+;; (file-modification-time sfile))))
+;; (if (and (number? modtime)
+;; (> (- (current-seconds) modtime)
+;; 600))
+;; (begin
+;; (debug:print 0 *default-log-port* "WARNING: found old server info file "sfile", removing it.")
+;; (handle-exceptions
+;; exn
+;; (debug:print 0 *default-log-port* "WARNING: failed to delete old server info file "sfile)
+;; (delete-file sfile))))))
+;; sfiles)))
+;;
+;; ;; would like to eventually get rid of this
+;; ;;
+;; (define (common:on-homehost?)
+;; (server:choose-server *toppath* 'home?))
+;;
+;; ;; kind start up of server, wait before allowing another server for a given
+;; ;; area to be launched
+;; ;;
+;; (define (server:kind-run areapath)
+;; ;; look for $MT_RUN_AREA_HOME/logs/server-start-last
+;; ;; and wait for it to be at least seconds old
+;; ;; (server:wait-for-server-start-last-flag areapath)
+;; (let loop ()
+;; (if (> (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f)) 2)
+;; (begin
+;; (if (common:low-noise-print 30 "our-host-load")
+;; (debug:print 0 *default-log-port* "WARNING: system load is high, waiting to start server."))
+;; (loop))))
+;; (if (< (server:choose-server areapath 'count) 20)
+;; (server:run areapath))
+;; #;(if (not (server:check-if-running areapath)) ;; why try if there is already a server running?
+;; (let* ((lock-file (conc areapath "/logs/server-start.lock")))
+;; (let* ((start-flag (conc areapath "/logs/server-start-last")))
+;; (common:simple-file-lock-and-wait lock-file expire-time: 25)
+;; (debug:print-info 2 *default-log-port* "server:kind-run: touching " start-flag)
+;; (system (conc "touch " start-flag)) ;; lazy but safe
+;; (server:run areapath)
+;; (thread-sleep! 20) ;; don't release the lock for at least a few seconds. And allow time for the server startup to get to "SERVER STARTED".
+;; (common:simple-file-release-lock lock-file)))
+;; (debug:print-info 0 *default-log-port* "Found server already running. NOT trying to start another.")))
+;;
+;; ;; this one seems to be the general entry point
+;; ;;
+;; (define (server:start-and-wait areapath #!key (timeout 60))
+;; (let ((give-up-time (+ (current-seconds) timeout)))
+;; (let loop ((server-info (server:check-if-running areapath))
+;; (try-num 0))
+;; (if (or server-info
+;; (> (current-seconds) give-up-time)) ;; server-url will be #f if no server available.
+;; (server:record->url server-info)
+;; (let* ( (servers (server:choose-server areapath 'all-valid))
+;; (num-ok (if servers (length (server:choose-server areapath 'all-valid)) 0)))
+;; (if (and (> try-num 0) ;; first time through simply wait a little while then try again
+;; (< num-ok 1)) ;; if there are no decent candidates for servers then try starting a new one
+;; (server:run areapath))
+;; (thread-sleep! 5)
+;; (loop (server:check-if-running areapath)
+;; (+ try-num 1)))))))
+;;
+;; (define (server:get-num-servers #!key (numservers 2))
+;; (let ((ns (string->number
+;; (or (configf:lookup *configdat* "server" "numservers") "notanumber"))))
+;; (or ns numservers)))
+;;
+;; ;; no longer care if multiple servers are started by accident. older servers will drop off in time.
+;; ;;
+;; (define (server:check-if-running areapath) ;; #!key (numservers "2"))
+;; (let* ((ns (server:get-num-servers)) ;; get the setting the for maximum number of servers allowed
+;; (servers (server:choose-server areapath 'best-ten))) ;; (server:get-best (server:get-list areapath))))
+;; (if (or (and servers
+;; (null? servers))
+;; (not servers))
+;; ;; (and (list? servers)
+;; ;; (< (length servers) (+ 1 (random ns))))) ;; somewhere between 1 and numservers
+;; #f
+;; (let loop ((hed (car servers))
+;; (tal (cdr servers)))
+;; (let ((res (server:check-server hed)))
+;; (if res
+;; hed
+;; (if (null? tal)
+;; #f
+;; (loop (car tal)(cdr tal)))))))))
+;;
+;; ;; ping the given server
+;; ;;
+;; (define (server:check-server server-record)
+;; (let* ((server-url (server:record->url server-record))
+;; (server-id (server:record->id server-record))
+;; (res (server:ping server-url server-id)))
+;; (if res
+;; server-url
+;; #f)))
+;;
+;; (define (server:kill servr)
+;; (handle-exceptions
+;; exn
+;; (begin
+;; (debug:print-info 0 *default-log-port* "Unable to get host and/or port from " servr ", exn=" exn)
+;; #f)
+;; (match-let (((mod-time hostname port start-time server-id pid)
+;; servr))
+;; (tasks:kill-server hostname pid))))
+;;
+;; ;; called in megatest.scm, host-port is string hostname:port
+;; ;;
+;; ;; NOTE: This is NOT called directly from clients as not all transports support a client running
+;; ;; in the same process as the server.
+;; ;;
+;; (define (server:ping host:port server-id #!key (do-exit #f))
+;; (let* ((host-port (cond
+;; ((string? host:port)
+;; (let ((slst (string-split host:port ":")))
+;; (if (eq? (length slst) 2)
+;; (list (car slst)(string->number (cadr slst)))
+;; #f)))
+;; (else
+;; #f))))
+;; (cond
+;; ((and (list? host-port)
+;; (eq? (length host-port) 2))
+;; (let* ((myrunremote (make-remote))
+;; (iface (car host-port))
+;; (port (cadr host-port))
+;; (server-dat (client:connect iface port server-id myrunremote))
+;; (login-res (rmt:login-no-auto-client-setup myrunremote)))
+;; (if (and (list? login-res)
+;; (car login-res))
+;; (begin
+;; ;; (print "LOGIN_OK")
+;; (if do-exit (exit 0))
+;; #t)
+;; (begin
+;; ;; (print "LOGIN_FAILED")
+;; (if do-exit (exit 1))
+;; #f))))
+;; (else
+;; (if host:port
+;; (debug:print 0 *default-log-port* "ERROR: bad host:port "host:port))
+;; (if do-exit
+;; (exit 1)
+;; #f)))))
+;;
+;; ;; run ping in separate process, safest way in some cases
+;; ;;
+;; (define (server:ping-server ifaceport)
+;; (with-input-from-pipe
+;; (conc (common:get-megatest-exe) " -ping " ifaceport)
+;; (lambda ()
+;; (let loop ((inl (read-line))
+;; (res "NOREPLY"))
+;; (if (eof-object? inl)
+;; (case (string->symbol res)
+;; ((NOREPLY) #f)
+;; ((LOGIN_OK) #t)
+;; (else #f))
+;; (loop (read-line) inl))))))
+;;
+;; ;; NOT USED (well, ok, reference in rpc-transport but otherwise not used).
+;; ;;
+;; (define (server:login toppath)
+;; (lambda (toppath)
+;; (set! *db-last-access* (current-seconds)) ;; might not be needed.
+;; (if (equal? *toppath* toppath)
+;; #t
+;; #f)))
+;;
+;; ;; timeout is hms string: 1h 5m 3s, default is 1 minute
+;; ;; This is currently broken. Just use the number of hours with no unit.
+;; ;; Default is 60 seconds.
+;; ;;
+;; (define (server:expiration-timeout)
+;; (let ((tmo (configf:lookup *configdat* "server" "timeout")))
+;; (if (and (string? tmo)
+;; (common:hms-string->seconds tmo)) ;; BUG: hms-string->seconds is broken, if given "10" returns 0. Also, it doesn't belong in this logic unless the string->number is changed below
+;; (* 3600 (string->number tmo))
+;; 600)))
+;;
+;; (define (server:get-best-guess-address hostname)
+;; (let ((res #f))
+;; (for-each
+;; (lambda (adr)
+;; (if (not (eq? (u8vector-ref adr 0) 127))
+;; (set! res adr)))
+;; ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME
+;; (vector->list (hostinfo-addresses (hostname->hostinfo hostname))))
+;; (string-intersperse
+;; (map number->string
+;; (u8vector->list
+;; (if res res (hostname->ip hostname)))) ".")))
+;;
+;; ;; (define server:sync-lock-token "SERVER_SYNC_LOCK")
+;; ;; (define (server:release-sync-lock)
+;; ;; (db:no-sync-del! *no-sync-db* server:sync-lock-token))
+;; ;; (define (server:have-sync-lock?)
+;; ;; (let* ((have-lock-pair (db:no-sync-get-lock *no-sync-db* server:sync-lock-token))
+;; ;; (have-lock? (car have-lock-pair))
+;; ;; (lock-time (cdr have-lock-pair))
+;; ;; (lock-age (- (current-seconds) lock-time)))
+;; ;; (cond
+;; ;; (have-lock? #t)
+;; ;; ((>lock-age
+;; ;; (* 3 (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 180)))
+;; ;; (server:release-sync-lock)
+;; ;; (server:have-sync-lock?))
+;; ;; (else #f))))
+;;
+;; ;; moving this here as it needs access to db and cannot be in common.
+;; ;;
+;;
+;; (define (server:get-bruteforce-syncer dbstruct #!key (fork-to-background #f) (persist-until-sync #f))
+;; (debug:print "WARNING: bruteforce-syncer is called but has been disabled!")
+;; (lambda ()
+;; (debug:print "WARNING: bruteforce-syncer is called but has been disabled!"))
+;; #;(let* ((sqlite-exe (or (get-environment-variable "MT_SQLITE3_EXE"))) ;; defined in cfg.sh
+;; (sync-log (or (args:get-arg "-sync-log") (conc *toppath* "/logs/sync-" (current-process-id) "-" (get-host-name) ".log")))
+;; (tmp-area (common:get-db-tmp-area))
+;; (tmp-db (conc tmp-area "/megatest.db"))
+;; (staging-file (conc *toppath* "/.megatest.db"))
+;; (mtdbfile (conc *toppath* "/megatest.db"))
+;; (lockfile (common:get-sync-lock-filepath))
+;; (sync-cmd-core (conc sqlite-exe" " tmp-db " .dump | "sqlite-exe" " staging-file "&>"sync-log))
+;; (sync-cmd (if fork-to-background
+;; (conc "/usr/bin/env NBFAKE_LOG="*toppath*"/logs/last-server-sync-"(current-process-id)".log nbfake \""sync-cmd-core" && /bin/mv -f " staging-file " " mtdbfile" \"")
+;; sync-cmd-core))
+;; (default-min-intersync-delay 2)
+;; (min-intersync-delay (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: default-min-intersync-delay))
+;; (default-duty-cycle 0.1)
+;; (duty-cycle (configf:lookup-number *configdat* "server" "sync-duty-cycle" default: default-duty-cycle))
+;; (last-sync-seconds 10) ;; we will adjust this to a measurement and delay last-sync-seconds * (1 - duty-cycle)
+;; (calculate-off-time (lambda (work-duration duty-cycle)
+;; (* (/ (- 1 duty-cycle) duty-cycle) last-sync-seconds)))
+;; (off-time min-intersync-delay) ;; adjusted in closure below.
+;; (do-a-sync
+;; (lambda ()
+;; (BB> "Start do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync)
+;; (let* ((finalres
+;; (let retry-loop ((num-tries 0))
+;; (if (common:simple-file-lock lockfile)
+;; (begin
+;; (cond
+;; ((not (or fork-to-background persist-until-sync))
+;; (debug:print 0 *default-log-port* "INFO: syncer thread sleeping for max of (server.minimum-intersync-delay="min-intersync-delay
+;; " , off-time="off-time" seconds ]")
+;; (thread-sleep! (max off-time min-intersync-delay)))
+;; (else
+;; (debug:print 0 *default-log-port* "INFO: syncer thread NOT sleeping ; maybe time-to-exit...")))
+;;
+;; (if (not (configf:lookup *configdat* "server" "disable-db-snapshot"))
+;; (common:snapshot-file mtdbfile subdir: ".db-snapshot"))
+;; (delete-file* staging-file)
+;; (let* ((start-time (current-milliseconds))
+;; (res (system sync-cmd))
+;; (dbbackupfile (conc mtdbfile ".backup"))
+;; (res2
+;; (cond
+;; ((eq? 0 res )
+;; (handle-exceptions
+;; exn
+;; #f
+;; (if (file-exists? dbbackupfile)
+;; (delete-file* dbbackupfile)
+;; )
+;; (if (eq? 0 (file-size sync-log))
+;; (delete-file* sync-log))
+;; (system (conc "/bin/mv " staging-file " " mtdbfile))
+;;
+;; (set! last-sync-seconds (/ (- (current-milliseconds) start-time) 1000))
+;; (set! off-time (calculate-off-time
+;; last-sync-seconds
+;; (cond
+;; ((and (number? duty-cycle) (> duty-cycle 0) (< duty-cycle 1))
+;; duty-cycle)
+;; (else
+;; (debug:print 0 *default-log-port* "WARNING: ["(common:human-time)"] server.sync-duty-cycle is invalid. Should be a number between 0 and 1, but "duty-cycle" was specified. Using default value: "default-duty-cycle)
+;; default-duty-cycle))))
+;;
+;; (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" SYNC took "last-sync-seconds" sec")
+;; (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" SYNC took "last-sync-seconds" sec ; with duty-cycle of "duty-cycle" off time is now "off-time)
+;; 'sync-completed))
+;; (else
+;; (system (conc "/bin/cp "sync-log" "sync-log".fail"))
+;; (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Sync failed. See log at "sync-log".fail")
+;; (if (file-exists? (conc mtdbfile ".backup"))
+;; (system (conc "/bin/cp "mtdbfile ".backup " mtdbfile)))
+;; #f))))
+;; (common:simple-file-release-lock lockfile)
+;; (BB> "released lockfile: " lockfile)
+;; (when (common:file-exists? lockfile)
+;; (BB> "DID NOT ACTUALLY RELEASE LOCKFILE"))
+;; res2) ;; end let
+;; );; end begin
+;; ;; else
+;; (cond
+;; (persist-until-sync
+;; (thread-sleep! 1)
+;; (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; we're in a fork-to-background so we need to succeed. Let's wait a jiffy and and try again. num-tries="num-tries" (waiting for lockfile="lockfile" to disappear)")
+;; (retry-loop (add1 num-tries)))
+;; (else
+;; (thread-sleep! (max off-time (+ last-sync-seconds min-intersync-delay)))
+;; (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; not syncing.")
+;; 'parallel-sync-in-progress))
+;; ) ;; end if got lockfile
+;; )
+;; ))
+;; (BB> "End do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync" and result="finalres)
+;; finalres)
+;; ) ;; end lambda
+;; ))
+;; do-a-sync))
+;;
+;;
ADDED servermod.scm
Index: servermod.scm
==================================================================
--- /dev/null
+++ servermod.scm
@@ -0,0 +1,24 @@
+;; Copyright 2006-2017, 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 .
+;;
+
+(declare (unit servermod))
+
+(module servermod
+*
+
+)
Index: tasks.scm
==================================================================
--- tasks.scm
+++ tasks.scm
@@ -22,11 +22,11 @@
(import (prefix sqlite3 sqlite3:))
(declare (unit tasks))
(declare (uses dbfile))
(declare (uses db))
-(declare (uses rmt))
+(declare (uses rmtmod))
(declare (uses common))
(declare (uses pgdb))
(import dbfile)
;; (import pgdb) ;; pgdb is a module
Index: tcmt.scm
==================================================================
--- tcmt.scm
+++ tcmt.scm
@@ -27,11 +27,11 @@
(use trace)
;; (trace-call-sites #t)
(declare (uses margs))
-(declare (uses rmt))
+(declare (uses rmtmod))
(declare (uses common))
;; (declare (uses megatest-version))
(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
Index: tdb.scm
==================================================================
--- tdb.scm
+++ tdb.scm
@@ -29,11 +29,11 @@
(declare (unit tdb))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
-(declare (uses client))
+(declare (uses clientmod))
(declare (uses mt))
(declare (uses db))
(include "common_records.scm")
(include "db_records.scm")
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -30,11 +30,11 @@
(declare (uses commonmod))
;; (declare (uses dcommon)) ;; needed for the steps processing
(declare (uses items))
(declare (uses runconfig))
;; (declare (uses sdb))
-(declare (uses server))
+(declare (uses servermod))
;;(declare (uses stml2))
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
(import (prefix sqlite3 sqlite3:))
(import commonmod)
Index: tree.scm
==================================================================
--- tree.scm
+++ tree.scm
@@ -30,11 +30,11 @@
(declare (uses margs))
(declare (uses launch))
;; (declare (uses megatest-version))
(declare (uses gutils))
(declare (uses db))
-(declare (uses server))
+;; (declare (uses server))
;; (declare (uses synchash))
(declare (uses dcommon))
(include "megatest-version.scm")
(include "common_records.scm")