Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -31,19 +31,20 @@
# server.scm http-transport.scm client.scm rmt.scm
# module source files
MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm \
configfmod.scm servermod.scm clientmod.scm rmtmod.scm \
- artifacts.scm
+ artifacts.scm apimod.scm
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
+mofiles/dbfile.o mofiles/clientmod.o mofiles/dbmod.o mofiles/rmtmod.o : mofiles/debugprint.o mofiles/commonmod.o # dbmod.import.o
db.o : dbmod.import.o
mofiles/debugprint.o : mofiles/mtargs.o
mofiles/servermod.o : mofiles/artifacts.o
+mofiles/rmtmod.o : mofiles/apimod.o
# ftail.scm rmtmod.scm commonmod.scm removed
# MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm \
# mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm \
# rmtmod.scm apimod.scm
@@ -176,11 +177,11 @@
tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o : run_records.scm
db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm
db.o api.o : mofiles/dbmod.o mofiles/dbfile.o mofiles/debugprint.o mofiles/commonmod.o dbmod.import.o
-tests.o tasks.o dashboard-tasks.o : task_records.scm
+# tests.o tasks.o dashboard-tasks.o : task_records.scm
runs.o : test_records.scm
mofiles-made : $(MOFILES)
make $(MOIMPFILES)
Index: api.scm
==================================================================
--- api.scm
+++ api.scm
@@ -26,124 +26,16 @@
(declare (uses rmtmod))
(declare (uses db))
(declare (uses dbmod))
(declare (uses dbfile))
(declare (uses tasks))
+(declare (uses debugprint))
(import dbmod)
(import dbfile)
-(import rmtmod)
-
-;; allow these queries through without starting a server
-;;
-(define api:read-only-queries
- '(get-key-val-pairs
- get-var
- get-keys
- get-key-vals
- test-toplevel-num-items
- get-test-info-by-id
- get-steps-info-by-id
- get-data-info-by-id
- test-get-rundir-from-test-id
- get-count-tests-running-for-testname
- get-count-tests-running
- get-count-tests-running-in-jobgroup
- get-previous-test-run-record
- get-matching-previous-test-run-records
- test-get-logfile-info
- test-get-records-for-index-file
- get-testinfo-state-status
- test-get-top-process-pid
- test-get-paths-matching-keynames-target-new
- get-prereqs-not-met
- get-count-tests-running-for-run-id
- get-run-info
- get-run-status
- get-run-state
- get-run-stats
- get-run-times
- get-targets
- get-target
- ;; register-run
- get-tests-tags
- get-test-times
- get-tests-for-run
- get-tests-for-run-state-status
- get-test-id
- get-tests-for-runs-mindata
- get-tests-for-run-mindata
- get-run-name-from-id
- get-runs
- simple-get-runs
- get-num-runs
- get-runs-cnt-by-patt
- get-all-run-ids
- get-prev-run-ids
- get-run-ids-matching-target
- get-runs-by-patt
- get-steps-data
- get-steps-for-test
- read-test-data
- read-test-data-varpatt
- login
- tasks-get-last
- testmeta-get-record
- have-incompletes?
- ;; synchash-get
- get-changed-record-ids
- get-run-record-ids
- get-not-completed-cnt))
-
-(define api:write-queries
- '(
- get-keys-write ;; dummy "write" query to force server start
-
- ;; SERVERS
- ;; start-server
- ;; kill-server
-
- ;; TESTS
- test-set-state-status-by-id
- delete-test-records
- delete-old-deleted-test-records
- test-set-state-status
- test-set-top-process-pid
- set-state-status-and-roll-up-items
-
- update-pass-fail-counts
- top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst")
-
- ;; RUNS
- register-run
- set-tests-state-status
- delete-run
- lock/unlock-run
- update-run-event_time
- mark-incomplete
- set-state-status-and-roll-up-run
- ;; STEPS
- teststep-set-status!
- delete-steps-for-test
- ;; TEST DATA
- test-data-rollup
- csv->test-data
-
- ;; MISC
- sync-inmem->db
- drop-all-triggers
- create-all-triggers
- update-tesdata-on-repilcate-db
-
- ;; TESTMETA
- testmeta-add-record
- testmeta-update-field
-
- ;; TASKS
- tasks-add
- tasks-set-state-given-param-key
- ))
+(import rmtmod
+ debugprint)
(define *db-write-mutexes* (make-hash-table))
;; These are called by the server on recipt of /api calls
;; - keep it simple, only return the actual result of the call, i.e. no meta info here
Index: apimod.scm
==================================================================
--- apimod.scm
+++ apimod.scm
@@ -18,17 +18,126 @@
;;======================================================================
(declare (unit apimod))
(declare (uses commonmod))
-(declare (uses ulex))
(module apimod
*
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
(import commonmod)
-(import (prefix ulex ulex:))
+
+;; allow these queries through without starting a server
+;;
+(define api:read-only-queries
+ '(get-key-val-pairs
+ get-var
+ get-keys
+ get-key-vals
+ test-toplevel-num-items
+ get-test-info-by-id
+ get-steps-info-by-id
+ get-data-info-by-id
+ test-get-rundir-from-test-id
+ get-count-tests-running-for-testname
+ get-count-tests-running
+ get-count-tests-running-in-jobgroup
+ get-previous-test-run-record
+ get-matching-previous-test-run-records
+ test-get-logfile-info
+ test-get-records-for-index-file
+ get-testinfo-state-status
+ test-get-top-process-pid
+ test-get-paths-matching-keynames-target-new
+ get-prereqs-not-met
+ get-count-tests-running-for-run-id
+ get-run-info
+ get-run-status
+ get-run-state
+ get-run-stats
+ get-run-times
+ get-targets
+ get-target
+ ;; register-run
+ get-tests-tags
+ get-test-times
+ get-tests-for-run
+ get-tests-for-run-state-status
+ get-test-id
+ get-tests-for-runs-mindata
+ get-tests-for-run-mindata
+ get-run-name-from-id
+ get-runs
+ simple-get-runs
+ get-num-runs
+ get-runs-cnt-by-patt
+ get-all-run-ids
+ get-prev-run-ids
+ get-run-ids-matching-target
+ get-runs-by-patt
+ get-steps-data
+ get-steps-for-test
+ read-test-data
+ read-test-data-varpatt
+ login
+ tasks-get-last
+ testmeta-get-record
+ have-incompletes?
+ ;; synchash-get
+ get-changed-record-ids
+ get-run-record-ids
+ get-not-completed-cnt))
+
+(define api:write-queries
+ '(
+ get-keys-write ;; dummy "write" query to force server start
+
+ ;; SERVERS
+ ;; start-server
+ ;; kill-server
+
+ ;; TESTS
+ test-set-state-status-by-id
+ delete-test-records
+ delete-old-deleted-test-records
+ test-set-state-status
+ test-set-top-process-pid
+ set-state-status-and-roll-up-items
+
+ update-pass-fail-counts
+ top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst")
+
+ ;; RUNS
+ register-run
+ set-tests-state-status
+ delete-run
+ lock/unlock-run
+ update-run-event_time
+ mark-incomplete
+ set-state-status-and-roll-up-run
+ ;; STEPS
+ teststep-set-status!
+ delete-steps-for-test
+ ;; TEST DATA
+ test-data-rollup
+ csv->test-data
+
+ ;; MISC
+ sync-inmem->db
+ drop-all-triggers
+ create-all-triggers
+ update-tesdata-on-repilcate-db
+
+ ;; TESTMETA
+ testmeta-add-record
+ testmeta-update-field
+
+ ;; TASKS
+ tasks-add
+ tasks-set-state-given-param-key
+ ))
+
)
Index: archive.scm
==================================================================
--- archive.scm
+++ archive.scm
@@ -21,13 +21,16 @@
(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18)
(declare (unit archive))
(declare (uses db))
(declare (uses common))
+(declare (uses debugprint))
(include "common_records.scm")
(include "db_records.scm")
+
+(import debugprint)
;;======================================================================
;;
;;======================================================================
ADDED attic/client.scm
Index: attic/client.scm
==================================================================
--- /dev/null
+++ attic/client.scm
@@ -0,0 +1,163 @@
+
+;; 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 client))
+
+(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)))
+;;
+;;
ADDED attic/http-transport.scm
Index: attic/http-transport.scm
==================================================================
--- /dev/null
+++ attic/http-transport.scm
@@ -0,0 +1,732 @@
+;; 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 .
+
+;; (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)
+;; " ")
+;; "
")))
+;;
+;; ;; http-server send-response
+;; ;; api:process-request
+;; ;; db:*
+;; ;;
+;; ;; NB// Runs on the server as part of the server loop
+;; ;;
+;; (define (api:process-request dbstruct $) ;; the $ is the request vars proc
+;; (debug:print 4 *default-log-port* "server-id:" *server-id*)
+;; (let* ((cmd ($ 'cmd))
+;; (paramsj ($ 'params))
+;; (key ($ 'key))
+;; (params (db:string->obj paramsj transport: 'http))) ;; incoming data from the POST (or is it a GET?)
+;; (debug:print 4 *default-log-port* "cmd:" cmd " with params " params "key " key)
+;; (if (equal? key *server-id*)
+;; (begin
+;; (set! *api-process-request-count* (+ *api-process-request-count* 1))
+;; (let* ((resdat (api:execute-requests dbstruct (vector cmd params))) ;; process the request, resdat = #( flag result )
+;; (success (vector-ref resdat 0))
+;; (res (vector-ref resdat 1))) ;; (vector flag payload), get the payload, ignore the flag (why?)
+;; (debug:print 4 *default-log-port* "res:" res)
+;; (if (not success)
+;; (debug:print 0 *default-log-port* "ERROR: success flag is #f for " cmd " with params " params))
+;; (if (> *api-process-request-count* *max-api-process-requests*)
+;; (set! *max-api-process-requests* *api-process-request-count*))
+;; (set! *api-process-request-count* (- *api-process-request-count* 1))
+;; ;; This can be here but needs controls to ensure it doesn't run more than every 4 seconds
+;; ;; (rmt:dat->json-str
+;; ;; (if (or (string? res)
+;; ;; (list? res)
+;; ;; (number? res)
+;; ;; (boolean? res))
+;; ;; res
+;; ;; (list "ERROR, not string, list, number or boolean" 1 cmd params res)))))
+;; (db:obj->string res transport: 'http)))
+;; (begin
+;; (debug:print 0 *default-log-port* "Server refused to process request. Server id mismatch. recived " key " expected: " *server-id* ".\nOther arguments recived: cmd=" cmd " params = " params)
+;; (db:obj->string (conc "Server refused to process request server-id mismatch: " key ", " *server-id*) transport: 'http)))))
+;;
+;;
ADDED attic/mockup-cached-writes.scm
Index: attic/mockup-cached-writes.scm
==================================================================
--- /dev/null
+++ attic/mockup-cached-writes.scm
@@ -0,0 +1,48 @@
+;; 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 .
+;;
+
+
+(define (make-cached-writer the-db)
+ (let ((db the-db)
+ (queue '()))
+ (lambda (cacheable . qry-params) ;; fn qry
+ (if cacheable
+ (begin
+ (set! queue (cons qry-params queue))
+ (call/cc))
+ (begin
+ (print "Starting transaction")
+ (for-each
+ (lambda (queue-item)
+ (let ((fn (car queue-item))
+ (qry (cdr queue-item)))
+ (print "WRITE to " db ": " qry)
+ )
+ (reverse queue))
+ (print "End transaction")
+ (print "READ from " db ": " qry-params))))))
+
+(define *cw* (make-cached-writer "the db"))
+
+(define (dbcall cacheable query)
+ (*cw* cacheable query))
+
+(dbcall #t "insert abc")
+(dbcall #t "insert def")
+(dbcall #t "insert hij")
+(dbcall #f "select foo")
ADDED attic/monitor.scm
Index: attic/monitor.scm
==================================================================
--- /dev/null
+++ attic/monitor.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 .
+
+;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
+
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking)
+(import (prefix sqlite3 sqlite3:))
+
+(declare (unit runs))
+(declare (uses db))
+(declare (uses common))
+(declare (uses items))
+(declare (uses runconfig))
+
+(include "common_records.scm")
+(include "key_records.scm")
+(include "db_records.scm")
+(include "run_records.scm")
+
ADDED attic/rmtdb.scm
Index: attic/rmtdb.scm
==================================================================
--- /dev/null
+++ attic/rmtdb.scm
@@ -0,0 +1,20 @@
+;;======================================================================
+;; Copyright 2006-2013, 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 .
+
+;;======================================================================
+
ADDED attic/server.scm
Index: attic/server.scm
==================================================================
--- /dev/null
+++ attic/server.scm
@@ -0,0 +1,871 @@
+;; 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 .
+;;
+
+;; (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 attic/synchash.scm
Index: attic/synchash.scm
==================================================================
--- /dev/null
+++ attic/synchash.scm
@@ -0,0 +1,133 @@
+;;======================================================================
+;; 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 .
+;;
+;;======================================================================
+
+;;======================================================================
+;; A hash of hashes that can be kept in sync by sending minial deltas
+;;======================================================================
+
+(use format)
+(use srfi-1 srfi-69 sqlite3)
+(import (prefix sqlite3 sqlite3:))
+
+(declare (unit synchash))
+(declare (uses db))
+(declare (uses server))
+(include "db_records.scm")
+
+(define (synchash:make)
+ (make-hash-table))
+
+;; given an alist of objects '((id obj) ...)
+;; 1. remove unchanged objects from the list
+;; 2. create a list of removed objects by id
+;; 3. remove removed objects from synchash
+;; 4. replace or add new or changed objects to synchash
+;;
+(define (synchash:get-delta indat synchash)
+ (let ((deleted '())
+ (changed '())
+ (found '())
+ (orig-keys (hash-table-keys synchash)))
+ (for-each
+ (lambda (item)
+ (let* ((id (car item))
+ (dat (cadr item))
+ (ref (hash-table-ref/default synchash id #f)))
+ (if (not (equal? dat ref)) ;; item changed or new
+ (begin
+ (set! changed (cons item changed))
+ (hash-table-set! synchash id dat)))
+ (set! found (cons id found))))
+ indat)
+ (for-each
+ (lambda (id)
+ (if (not (member id found))
+ (begin
+ (set! deleted (cons id deleted))
+ (hash-table-delete! synchash id))))
+ orig-keys)
+ (list changed deleted)
+ ;; (list indat '()) ;; just for debugging
+ ))
+
+;; keynum => the field to use as the unique key (usually 0 but can be other field)
+;;
+(define (synchash:client-get proc synckey keynum synchash run-id . params)
+ (let* ((data (rmt:synchash-get run-id proc synckey keynum params))
+ (newdat (car data))
+ (removs (cadr data))
+ (myhash (hash-table-ref/default synchash synckey #f)))
+ (if (not myhash)
+ (begin
+ (set! myhash (make-hash-table))
+ (hash-table-set! synchash synckey myhash)))
+ (for-each
+ (lambda (item)
+ (let ((id (car item))
+ (dat (cadr item)))
+ ;; (debug:print-info 2 *default-log-port* "Processing item: " item)
+ (hash-table-set! myhash id dat)))
+ newdat)
+ (for-each
+ (lambda (id)
+ (hash-table-delete! myhash id))
+ removs)
+ ;; WHICH ONE!?
+ ;; data)) ;; return the changed and deleted list
+ (list newdat removs))) ;; synchash))
+
+(define *synchashes* (make-hash-table))
+
+(define (synchash:server-get dbstruct run-id proc synckey keynum params)
+ ;; (debug:print-info 2 *default-log-port* "synckey: " synckey ", keynum: " keynum ", params: " params)
+ (let* ((dbdat (db:get-db dbstruct run-id))
+ (db (db:dbdat-get-db dbdat))
+ (synchash (hash-table-ref/default *synchashes* synckey #f))
+ (newdat (apply (case proc
+ ((db:get-runs) db:get-runs)
+ ((db:get-tests-for-run-mindata) db:get-tests-for-run-mindata)
+ ((db:get-test-info-by-ids) db:get-test-info-by-ids)
+ (else
+ (print "ERROR: sync for hash " proc " not setup! Edits needed in synchash.scm")
+ print))
+ db params))
+ (postdat #f)
+ (make-indexed (lambda (x)
+ (list (vector-ref x keynum) x))))
+ ;; Now process newdat based on the query type
+ (set! postdat (case proc
+ ((db:get-runs)
+ ;; (debug:print-info 2 *default-log-port* "Get runs call")
+ (let ((header (vector-ref newdat 0))
+ (data (vector-ref newdat 1)))
+ ;; (debug:print-info 2 *default-log-port* "header: " header ", data: " data)
+ (cons (list "header" header) ;; add the header keyed by the word "header"
+ (map make-indexed data)))) ;; add each element keyed by the keynum'th val
+ (else
+ ;; (debug:print-info 2 *default-log-port* "Non-get runs call")
+ (map make-indexed newdat))))
+ ;; (debug:print-info 2 *default-log-port* "postdat: " postdat)
+ ;; (if (not indb)(sqlite3:finalize! db))
+ (if (not synchash)
+ (begin
+ (set! synchash (make-hash-table))
+ (hash-table-set! *synchashes* synckey synchash)))
+ (synchash:get-delta postdat synchash)))
+
ADDED attic/task_records.scm
Index: attic/task_records.scm
==================================================================
--- /dev/null
+++ attic/task_records.scm
@@ -0,0 +1,44 @@
+;;======================================================================
+;; 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 .
+;;======================================================================
+
+;; make-vector-record tasks task id action owner state target name test item params creation_time execution_time
+(define (make-tasks:task)(make-vector 11))
+(define-inline (tasks:task-get-id vec) (vector-ref vec 0))
+(define-inline (tasks:task-get-action vec) (vector-ref vec 1))
+(define-inline (tasks:task-get-owner vec) (vector-ref vec 2))
+(define-inline (tasks:task-get-state vec) (vector-ref vec 3))
+(define-inline (tasks:task-get-target vec) (vector-ref vec 4))
+(define-inline (tasks:task-get-name vec) (vector-ref vec 5))
+(define-inline (tasks:task-get-testpatt vec) (vector-ref vec 6))
+(define-inline (tasks:task-get-keylock vec) (vector-ref vec 7))
+(define-inline (tasks:task-get-params vec) (vector-ref vec 8))
+(define-inline (tasks:task-get-creation_time vec) (vector-ref vec 9))
+(define-inline (tasks:task-get-execution_time vec) (vector-ref vec 10))
+
+(define-inline (tasks:task-set-state! vec val)(vector-set! vec 3 val))
+
+
+;; make-vector-record tasks monitor id pid start_time last_update hostname username
+(define (make-tasks:monitor)(make-vector 5))
+(define-inline (tasks:monitor-get-id vec) (vector-ref vec 0))
+(define-inline (tasks:monitor-get-pid vec) (vector-ref vec 1))
+(define-inline (tasks:monitor-get-start_time vec) (vector-ref vec 2))
+(define-inline (tasks:monitor-get-last_update vec) (vector-ref vec 3))
+(define-inline (tasks:monitor-get-hostname vec) (vector-ref vec 4))
+(define-inline (tasks:monitor-get-username vec) (vector-ref vec 5))
DELETED client.scm
Index: client.scm
==================================================================
--- client.scm
+++ /dev/null
@@ -1,163 +0,0 @@
-
-;; 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 client))
-
-(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)))
-;;
-;;
Index: clientmod.scm
==================================================================
--- clientmod.scm
+++ clientmod.scm
@@ -25,31 +25,40 @@
;; spiffy-request-vars uri-common intarweb directory-utils)
(declare (unit clientmod))
(declare (uses servermod))
(declare (uses artifacts))
+(declare (uses debugprint))
(module clientmod
*
(import scheme
+ chicken
+
posix
data-structures
srfi-18
typed-records
artifacts
servermod
+ debugprint
)
(defstruct con ;; client connection
- (hdir #f)
+ (hdir #f) ;; this is the directory sdir/serverhost.serverpid
+ (sdir #f)
(obj-to-str #f)
+ (str-to-obj #f)
(host #f)
(pid #f)
(sdat #f) ;; server artifact data
+ (areapath #f)
)
+
+(define *my-client-signature* #f)
(define (client:find-server areapath)
(let* ((sdir (conc areapath"/.server"))
(sarfs (glob (conc sdir"/*.artifact")))) ;; server artifacts
(if (null? sarfs)
@@ -58,23 +67,53 @@
(thread-sleep! 1)
(client:find-server areapath))
(let* ((sarf (car sarfs))
(sdat (read-artifact->alist sarf))
(hdir (alist-ref 'd sdat)))
- (make-con hdir: hdir sdat: sdat)))))
+ (make-con hdir: hdir sdir: sdir sdat: sdat)))))
+
+;; move this into artifacts
+;; find the artifact with key set to val
+;;
+(define (client:find-artifact arfs key val)
+ (let loop ((rem arfs))
+ (if (null? rem) ;; didn't find a match
+ #f
+ (let* ((arf (car rem))
+ (adat (read-artifact->alist arf))
+ (val-found (alist-ref key adat)))
+ (if (equal? val-found val)
+ (cons (cons 'path arf) adat) ;; return the artifact as alist anotated with 'path
+ (loop (cdr rem)))))))
(define (client:send-receive con cmd params)
(let* ((obj->string (con-obj-to-str con))
+ (string->obj (con-str-to-obj con))
(arf `((c . ,cmd)
(p . ,(obj->string params))
- (h . ,(con-host con))
- (i . ,(con-pid con))))
+ (h . ,(con-host con)) ;; tells server where to put response
+ (i . ,(con-pid con))));; and is where this client looks
(hdir (con-hdir con))
- (uuid (write-alist->artifact hdir arf ptype: 'Q)))
-
- ;; wait for a response here
+ (sdir (con-sdir con))
+ (uuid (write-alist->artifact hdir arf ptype: 'Q))
+ (respdir (conc sdir"/"(con-host con)"."(con-pid con)"/responses")))
+ (let loop ((start (current-milliseconds)))
+ (let* ((arfs (glob (conc respdir"/*.artifact")))
+ (res (client:find-artifact arfs 'P uuid)))
+ (if res ;; we found our response!
+ (let ((arf (alist-ref 'path res))
+ (rstr (alist-ref 'r res)))
+ (delete-file arf) ;; done with it, future - move to archive area
+ (string->obj rstr))
+ (begin ;; no response yet, look again in 500ms
+ (thread-sleep! 0.5)
+ (loop (current-milliseconds))))))))
- #f
- ))
+;; 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*)))
)
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -27,11 +27,14 @@
pkts (prefix dbi dbi:)
)
(declare (unit common))
(declare (uses commonmod))
-(import commonmod)
+(declare (uses debugprint))
+
+(import commonmod
+ debugprint)
(include "common_records.scm")
;; (require-library margs)
@@ -132,11 +135,11 @@
(define *pkts-info* (make-hash-table)) ;; store stuff like the last parent here
(define *configinfo* #f) ;; raw results from setup, includes toppath and table from megatest.config
(define *runconfigdat* #f) ;; run configs data
(define *configdat* #f) ;; megatest.config data
(define *configstatus* #f) ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done
-(define *toppath* #f)
+
(define *already-seen-runconfig-info* #f)
(define *test-meta-updated* (make-hash-table))
(define *globalexitstatus* 0) ;; attempt to work around possible thread issues
(define *passnum* 0) ;; when running track calls to run-tests or similar
@@ -147,13 +150,10 @@
(define *on-exit-procs* '()) ;; add procs to this list to be executed on exit
(define *default-area-tag* "local")
;; DATABASE
;; (define *dbstruct-dbs* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this.
-;; db stats
-(define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total >
-(define *db-stats-mutex* (make-mutex))
;; db access
(define *db-last-access* (current-seconds)) ;; last db access, used in server
;; (define *db-write-access* #t)
;; db sync
;; (define *db-last-sync* 0) ;; last time the sync to megatest.db happened
@@ -171,11 +171,10 @@
;; (define *no-sync-db* #f) ;; moved to dbfile
;; SERVER
(define *my-client-signature* #f)
(define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg
-(define *runremote* #f) ;; if set up for server communication this will hold
;; (define *max-cache-size* 0)
(define *logged-in-clients* (make-hash-table))
(define *server-id* #f)
(define *server-info* #f) ;; good candidate for easily convert to non-global
(define *time-to-exit* #f)
Index: common_records.scm
==================================================================
--- common_records.scm
+++ common_records.scm
@@ -77,137 +77,137 @@
(mutex-lock! mtx)
(let ((res (apply accessor record val)))
(mutex-unlock! mtx)
res))
-;; this was cached based on results from profiling but it turned out the profiling
-;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
-;; in for now but can probably take it out later.
-;;
-(define (debug:calc-verbosity vstr)
- (or (hash-table-ref/default *verbosity-cache* vstr #f)
- (let ((res (cond
- ((number? vstr) vstr)
- ((not (string? vstr)) 1)
- ;; ((string-match "^\\s*$" vstr) 1)
- (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ",")))))
- (cond
- ((> (length debugvals) 1) debugvals)
- ((> (length debugvals) 0)(car debugvals))
- (else 1))))
- ((args:get-arg "-v") 2)
- ((args:get-arg "-q") 0)
- (else 1))))
- (hash-table-set! *verbosity-cache* vstr res)
- res)))
-
-;; check verbosity, #t is ok
-(define (debug:check-verbosity verbosity vstr)
- (if (not (or (number? verbosity)
- (list? verbosity)))
- (begin
- (print "ERROR: Invalid debug value \"" vstr "\"")
- #f)
- #t))
-
-(define (debug:debug-mode n)
- (cond
- ((and (number? *verbosity*) ;; number number
- (number? n))
- (<= n *verbosity*))
- ((and (list? *verbosity*) ;; list number
- (number? n))
- (member n *verbosity*))
- ((and (list? *verbosity*) ;; list list
- (list? n))
- (not (null? (lset-intersection! eq? *verbosity* n))))
- ((and (number? *verbosity*)
- (list? n))
- (member *verbosity* n))))
-
-(define (debug:setup)
- (let ((debugstr (or (args:get-arg "-debug")
- (args:get-arg "-debug-noprop")
- (getenv "MT_DEBUG_MODE"))))
- (set! *verbosity* (debug:calc-verbosity debugstr))
- (debug:check-verbosity *verbosity* debugstr)
- ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
- (if (not *verbosity*)(set! *verbosity* 1))
- (if (and (not (args:get-arg "-debug-noprop"))
- (or (args:get-arg "-debug")
- (not (getenv "MT_DEBUG_MODE"))))
- (setenv "MT_DEBUG_MODE" (if (list? *verbosity*)
- (string-intersperse (map conc *verbosity*) ",")
- (conc *verbosity*))))))
-
-(define (debug:print n e . params)
- (if (debug:debug-mode n)
- (with-output-to-port (or e (current-error-port))
- (lambda ()
- (if *logging*
- (db:log-event (apply conc params))
- (apply print params)
- )))))
-
-;; Brandon's debug printer shortcut (indulge me :)
-(define *BB-process-starttime* (current-milliseconds))
-(define (BB> . in-args)
- (let* ((stack (get-call-chain))
- (location "??"))
- (for-each
- (lambda (frame)
- (let* ((this-loc (vector-ref frame 0))
- (temp (string-split (->string this-loc) " "))
- (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???")))
- (if (equal? this-func "BB>")
- (set! location this-loc))))
- stack)
- (let* ((color-on "\x1b[1m")
- (color-off "\x1b[0m")
- (dp-args
- (append
- (list 0 *default-log-port*
- (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off " ") )
- in-args)))
- (apply debug:print dp-args))))
-
-(define *BBpp_custom_expanders_list* (make-hash-table))
-
-
-
-;; register hash tables with BBpp.
-(hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE:
- (cons hash-table? hash-table->alist))
-
-;; test name converter
-(define (BBpp_custom_converter arg)
- (let ((res #f))
- (for-each
- (lambda (custom-type-name)
- (let* ((custom-type-info (hash-table-ref *BBpp_custom_expanders_list* custom-type-name))
- (custom-type-test (car custom-type-info))
- (custom-type-converter (cdr custom-type-info)))
- (when (and (not res) (custom-type-test arg))
- (set! res (custom-type-converter arg)))))
- (hash-table-keys *BBpp_custom_expanders_list*))
- (if res (BBpp_ res) arg)))
-
-(define (BBpp_ arg)
- (cond
- ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg)))
- ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg)))
- ((hash-table? arg)
- (let ((al (hash-table->alist arg)))
- (BBpp_ (cons HASH_TABLE: al))))
- ((null? arg) '())
- ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
- ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
- (else (BBpp_custom_converter arg))))
-
-;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp
-(define (BBpp arg)
- (pp (BBpp_ arg)))
+;; ;; this was cached based on results from profiling but it turned out the profiling
+;; ;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
+;; ;; in for now but can probably take it out later.
+;; ;;
+;; (define (debug:calc-verbosity vstr)
+;; (or (hash-table-ref/default *verbosity-cache* vstr #f)
+;; (let ((res (cond
+;; ((number? vstr) vstr)
+;; ((not (string? vstr)) 1)
+;; ;; ((string-match "^\\s*$" vstr) 1)
+;; (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ",")))))
+;; (cond
+;; ((> (length debugvals) 1) debugvals)
+;; ((> (length debugvals) 0)(car debugvals))
+;; (else 1))))
+;; ((args:get-arg "-v") 2)
+;; ((args:get-arg "-q") 0)
+;; (else 1))))
+;; (hash-table-set! *verbosity-cache* vstr res)
+;; res)))
+;;
+;; ;; check verbosity, #t is ok
+;; (define (debug:check-verbosity verbosity vstr)
+;; (if (not (or (number? verbosity)
+;; (list? verbosity)))
+;; (begin
+;; (print "ERROR: Invalid debug value \"" vstr "\"")
+;; #f)
+;; #t))
+;;
+;; (define (debug:debug-mode n)
+;; (cond
+;; ((and (number? *verbosity*) ;; number number
+;; (number? n))
+;; (<= n *verbosity*))
+;; ((and (list? *verbosity*) ;; list number
+;; (number? n))
+;; (member n *verbosity*))
+;; ((and (list? *verbosity*) ;; list list
+;; (list? n))
+;; (not (null? (lset-intersection! eq? *verbosity* n))))
+;; ((and (number? *verbosity*)
+;; (list? n))
+;; (member *verbosity* n))))
+;;
+;; (define (debug:setup)
+;; (let ((debugstr (or (args:get-arg "-debug")
+;; (args:get-arg "-debug-noprop")
+;; (getenv "MT_DEBUG_MODE"))))
+;; (set! *verbosity* (debug:calc-verbosity debugstr))
+;; (debug:check-verbosity *verbosity* debugstr)
+;; ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
+;; (if (not *verbosity*)(set! *verbosity* 1))
+;; (if (and (not (args:get-arg "-debug-noprop"))
+;; (or (args:get-arg "-debug")
+;; (not (getenv "MT_DEBUG_MODE"))))
+;; (setenv "MT_DEBUG_MODE" (if (list? *verbosity*)
+;; (string-intersperse (map conc *verbosity*) ",")
+;; (conc *verbosity*))))))
+;;
+;; (define (debug:print n e . params)
+;; (if (debug:debug-mode n)
+;; (with-output-to-port (or e (current-error-port))
+;; (lambda ()
+;; (if *logging*
+;; (db:log-event (apply conc params))
+;; (apply print params)
+;; )))))
+;;
+;; ;; Brandon's debug printer shortcut (indulge me :)
+;; (define *BB-process-starttime* (current-milliseconds))
+;; (define (BB> . in-args)
+;; (let* ((stack (get-call-chain))
+;; (location "??"))
+;; (for-each
+;; (lambda (frame)
+;; (let* ((this-loc (vector-ref frame 0))
+;; (temp (string-split (->string this-loc) " "))
+;; (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???")))
+;; (if (equal? this-func "BB>")
+;; (set! location this-loc))))
+;; stack)
+;; (let* ((color-on "\x1b[1m")
+;; (color-off "\x1b[0m")
+;; (dp-args
+;; (append
+;; (list 0 *default-log-port*
+;; (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off " ") )
+;; in-args)))
+;; (apply debug:print dp-args))))
+;;
+;; (define *BBpp_custom_expanders_list* (make-hash-table))
+;;
+;;
+;;
+;; ;; register hash tables with BBpp.
+;; (hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE:
+;; (cons hash-table? hash-table->alist))
+;;
+;; ;; test name converter
+;; (define (BBpp_custom_converter arg)
+;; (let ((res #f))
+;; (for-each
+;; (lambda (custom-type-name)
+;; (let* ((custom-type-info (hash-table-ref *BBpp_custom_expanders_list* custom-type-name))
+;; (custom-type-test (car custom-type-info))
+;; (custom-type-converter (cdr custom-type-info)))
+;; (when (and (not res) (custom-type-test arg))
+;; (set! res (custom-type-converter arg)))))
+;; (hash-table-keys *BBpp_custom_expanders_list*))
+;; (if res (BBpp_ res) arg)))
+;;
+;; (define (BBpp_ arg)
+;; (cond
+;; ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg)))
+;; ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg)))
+;; ((hash-table? arg)
+;; (let ((al (hash-table->alist arg)))
+;; (BBpp_ (cons HASH_TABLE: al))))
+;; ((null? arg) '())
+;; ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
+;; ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
+;; (else (BBpp_custom_converter arg))))
+;;
+;; ;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp
+;; (define (BBpp arg)
+;; (pp (BBpp_ arg)))
;(use define-macro)
(define-syntax inspect
(syntax-rules ()
[(_ x)
Index: commonmod.scm
==================================================================
--- commonmod.scm
+++ commonmod.scm
@@ -41,10 +41,20 @@
;;======================================================================
(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
+;; Globals
+
+(define *runremote* #f) ;; if set up for server communication this will hold
+;; db stats
+(define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total >
+(define *db-stats-mutex* (make-mutex))
+(define *toppath* #f)
+(define *db-keys* #f)
+(define *keyvals* #f)
+
(define (get-full-version)
(conc megatest-version "-" megatest-fossil-hash))
(define (version-signature)
(conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
@@ -213,13 +223,6 @@
;;======================================================================
;; misc stuff
;;======================================================================
-;; (define (debug:print . params) #f)
-;; (define (debug:print-info . params) #f)
-;;
-;; (define (set-functions dbgp dbgpinfo)
-;; (set! debug:print dbgp)
-;; (set! debug:print-info dbgpinfo))
-
)
Index: configf.scm
==================================================================
--- configf.scm
+++ configf.scm
@@ -25,12 +25,15 @@
(use regex regex-case matchable) ;; directory-utils)
(declare (unit configf))
(declare (uses process))
(declare (uses env))
(declare (uses keys))
+(declare (uses debugprint))
(include "common_records.scm")
+
+(import debugprint)
;; return list (path fullpath configname)
(define (find-config configname #!key (toppath #f))
(if toppath
(let ((cfname (conc toppath "/" configname)))
Index: configfmod.scm
==================================================================
--- configfmod.scm
+++ configfmod.scm
@@ -17,12 +17,12 @@
;; along with Megatest. If not, see .
;;======================================================================
(declare (unit configfmod))
-;; (declare (uses mtargs))
-;; (declare (uses debugprint))
+(declare (uses mtargs))
+(declare (uses debugprint))
;; (declare (uses keysmod))
(module configfmod
*
@@ -44,12 +44,12 @@
;; chicken.sort
;; chicken.string
;; chicken.time
;; chicken.eval
;;
-;; debugprint
-;; (prefix mtargs args:)
+ debugprint
+ (prefix mtargs args:)
;; pkts
;; keysmod
;;
;; (prefix base64 base64:)
;; (prefix dbi dbi:)
Index: dashboard-context-menu.scm
==================================================================
--- dashboard-context-menu.scm
+++ dashboard-context-menu.scm
@@ -39,14 +39,18 @@
(declare (uses rmtmod))
(declare (uses ezsteps))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrun))
+(declare (uses debugprint))
+
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
+
+(import debugprint)
(define (dboard:launch-testpanel run-id test-id)
(let* ((dboardexe (common:find-local-megatest "dashboard"))
(cmd (conc dboardexe
" -test " run-id "," test-id
Index: dashboard-guimonitor.scm
==================================================================
--- dashboard-guimonitor.scm
+++ dashboard-guimonitor.scm
@@ -38,11 +38,10 @@
(declare (uses tasks))
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
-(include "task_records.scm")
(define (control-panel db tdb keys)
(let* ((var-params (make-hash-table)) ;; register all the widgets here for querying on run, rollup, remove?
(key-params (make-hash-table))
(monitordat '()) ;; list of monitor records
Index: dashboard-tests.scm
==================================================================
--- dashboard-tests.scm
+++ dashboard-tests.scm
@@ -38,14 +38,17 @@
(declare (uses rmtmod))
(declare (uses ezsteps))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrun))
+(declare (uses debugprint))
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
+
+(import debugprint)
;;======================================================================
;; C O M M O N
;;======================================================================
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -45,18 +45,21 @@
(declare (uses dashboard-context-menu))
(declare (uses vg))
(declare (uses subrun))
(declare (uses mt))
(declare (uses dbfile))
+(declare (uses debugprint))
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
-(include "task_records.scm")
+
(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
(include "vg_records.scm")
+
+(import debugprint)
(dbfile:db-init-proc db:initialize-main-db)
(define help (conc
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -47,11 +47,11 @@
files)
(declare (unit db))
(declare (uses common))
(declare (uses dbmod))
-;; (declare (uses debugprint))
+(declare (uses debugprint))
(declare (uses dbfile))
(declare (uses keys))
(declare (uses ods))
;; (declare (uses client))
(declare (uses mt))
@@ -62,12 +62,13 @@
(include "run_records.scm")
(define *number-of-writes* 0)
(define *number-non-write-queries* 0)
-(import dbmod)
-(import dbfile)
+(import dbmod
+ dbfile
+ debugprint)
;; record for keeping state,status and count for doing roll-ups in
;; iterated tests
;;
(defstruct dbr:counts
@@ -3144,42 +3145,42 @@
;;======================================================================
;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS
;;======================================================================
-;; NOTE: Can remove the regex and base64 encoding for zmq
-(define (db:obj->string obj #!key (transport 'http))
- (case transport
- ;; ((fs) obj)
- ((http fs)
- (string-substitute
- (regexp "=") "_"
- (base64:base64-encode
- (z3:encode-buffer
- (with-output-to-string
- (lambda ()(serialize obj))))) ;; BB: serialize - this is what causes problems between different builds of megatest communicating. serialize is sensitive to binary image of mtest.
- #t))
- ((zmq nmsg)(with-output-to-string (lambda ()(serialize obj))))
- (else obj))) ;; rpc
-
-(define (db:string->obj msg #!key (transport 'http))
- (case transport
- ;; ((fs) msg)
- ((http fs)
- (if (string? msg)
- (with-input-from-string
- (z3:decode-buffer
- (base64:base64-decode
- (string-substitute
- (regexp "_") "=" msg #t)))
- (lambda ()(deserialize)))
- (begin
- (debug:print-error 0 *default-log-port* "reception failed. Received \"" msg "\" but cannot translate it.")
- (print-call-chain (current-error-port))
- msg))) ;; crude reply for when things go awry
- ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
- (else msg))) ;; rpc
+;; ;; NOTE: Can remove the regex and base64 encoding for zmq
+;; (define (db:obj->string obj #!key (transport 'http))
+;; (case transport
+;; ;; ((fs) obj)
+;; ((http fs)
+;; (string-substitute
+;; (regexp "=") "_"
+;; (base64:base64-encode
+;; (z3:encode-buffer
+;; (with-output-to-string
+;; (lambda ()(serialize obj))))) ;; BB: serialize - this is what causes problems between different builds of megatest communicating. serialize is sensitive to binary image of mtest.
+;; #t))
+;; ((zmq nmsg)(with-output-to-string (lambda ()(serialize obj))))
+;; (else obj))) ;; rpc
+;;
+;; (define (db:string->obj msg #!key (transport 'http))
+;; (case transport
+;; ;; ((fs) msg)
+;; ((http fs)
+;; (if (string? msg)
+;; (with-input-from-string
+;; (z3:decode-buffer
+;; (base64:base64-decode
+;; (string-substitute
+;; (regexp "_") "=" msg #t)))
+;; (lambda ()(deserialize)))
+;; (begin
+;; (debug:print-error 0 *default-log-port* "reception failed. Received \"" msg "\" but cannot translate it.")
+;; (print-call-chain (current-error-port))
+;; msg))) ;; crude reply for when things go awry
+;; ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
+;; (else msg))) ;; rpc
;; ; This is to be the big daddy call NOPE: Replaced by db:set-state-status-and-roll-up-items
;; ;
;; define (db:test-set-state-status dbstruct run-id test-id state status msg)
;; (let ((dbdat (db:get-subdb dbstruct run-id)))
Index: dbfile.scm
==================================================================
--- dbfile.scm
+++ dbfile.scm
@@ -17,11 +17,11 @@
;; along with Megatest. If not, see .
;;======================================================================
(declare (unit dbfile))
-;; (declare (uses debugprint))
+(declare (uses debugprint))
(declare (uses commonmod))
(module dbfile
*
@@ -37,14 +37,13 @@
stack
files
ports
commonmod
+ debugprint
)
-;; (import debugprint)
-
;;======================================================================
;; R E C O R D S
;;======================================================================
;; a single Megatest area with it's multiple dbs is
Index: dbmod.scm
==================================================================
--- dbmod.scm
+++ dbmod.scm
@@ -17,24 +17,72 @@
;; along with Megatest. If not, see .
;;======================================================================
(declare (unit dbmod))
+(declare (uses debugprint))
(module dbmod
*
-(import scheme chicken data-structures extras)
+(import scheme
+ chicken
+ ports
+ s11n
+ z3
+
+ data-structures
+ extras
+ (prefix base64 base64:)
+ message-digest
+ regex
+
+ debugprint
+ )
+
(import (prefix sqlite3 sqlite3:)
posix typed-records srfi-18
srfi-69)
(define (db:run-id->dbname run-id)
(cond
((number? run-id)(conc run-id ".db"))
((not run-id) "main.db")
(else run-id)))
+
+;; NOTE: Can remove the regex and base64 encoding for zmq
+(define (db:obj->string obj #!key (transport 'http))
+ (case transport
+ ;; ((fs) obj)
+ ((http fs)
+ (string-substitute
+ (regexp "=") "_"
+ (base64:base64-encode
+ (z3:encode-buffer
+ (with-output-to-string
+ (lambda ()(serialize obj))))) ;; BB: serialize - this is what causes problems between different builds of megatest communicating. serialize is sensitive to binary image of mtest.
+ #t))
+ ((zmq nmsg)(with-output-to-string (lambda ()(serialize obj))))
+ (else obj))) ;; rpc
+
+(define (db:string->obj msg #!key (transport 'http))
+ (case transport
+ ;; ((fs) msg)
+ ((http fs)
+ (if (string? msg)
+ (with-input-from-string
+ (z3:decode-buffer
+ (base64:base64-decode
+ (string-substitute
+ (regexp "_") "=" msg #t)))
+ (lambda ()(deserialize)))
+ (begin
+ (debug:print-error 0 *default-log-port* "reception failed. Received \"" msg "\" but cannot translate it.")
+ (print-call-chain (current-error-port))
+ msg))) ;; crude reply for when things go awry
+ ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
+ (else msg))) ;; rpc
;;======================================================================
;; hash of hashs
;;======================================================================
Index: dcommon.scm
==================================================================
--- dcommon.scm
+++ dcommon.scm
@@ -28,12 +28,15 @@
(declare (unit dcommon))
(declare (uses gutils))
(declare (uses db))
(declare (uses commonmod))
+(declare (uses debugprint))
-(import commonmod)
+(import commonmod
+ debugprint
+ )
;; (declare (uses synchash))
(include "megatest-version.scm")
(include "common_records.scm")
(include "db_records.scm")
Index: diff-report.scm
==================================================================
--- diff-report.scm
+++ diff-report.scm
@@ -17,15 +17,18 @@
;;
(declare (unit diff-report))
(declare (uses common))
(declare (uses rmtmod))
+(declare (uses debugprint))
(include "common_records.scm")
(use matchable)
(use fmt)
(use ducttape-lib)
+(import debugprint)
+
(define css "")
(define (diff:tests-mindat->hash tests-mindat)
(let* ((res (make-hash-table)))
(for-each
Index: env.scm
==================================================================
--- env.scm
+++ env.scm
@@ -17,12 +17,15 @@
;; along with Megatest. If not, see .
;;======================================================================
(declare (unit env))
+(declare (uses debugprint))
(use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)
+
+(import debugprint)
(define (env:open-db fname)
(let* ((db-exists (common:file-exists? fname))
(db (open-database fname)))
(if (not db-exists)
Index: ezsteps.scm
==================================================================
--- ezsteps.scm
+++ ezsteps.scm
@@ -25,19 +25,20 @@
(declare (unit ezsteps))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
+(declare (uses debugprint))
;; (declare (uses sdb))
;; (declare (uses filedb))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
-
+(import debugprint)
;;(rmt:get-test-info-by-id run-id test-id) -> testdat
;; TODO: deprecate me in favor of ezsteps.scm
;;
(define (launch:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat)
Index: genexample.scm
==================================================================
--- genexample.scm
+++ genexample.scm
@@ -17,11 +17,14 @@
;; along with Megatest. If not, see .
;;======================================================================
(declare (unit genexample))
+(declare (uses debugprint))
+
(use posix regex matchable)
+(import debugprint)
(include "db_records.scm")
(define genexample:example-logpro
#<.
-
-;; (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)
-;; " ")
-;; "
")))
-;;
-;; ;; http-server send-response
-;; ;; api:process-request
-;; ;; db:*
-;; ;;
-;; ;; NB// Runs on the server as part of the server loop
-;; ;;
-;; (define (api:process-request dbstruct $) ;; the $ is the request vars proc
-;; (debug:print 4 *default-log-port* "server-id:" *server-id*)
-;; (let* ((cmd ($ 'cmd))
-;; (paramsj ($ 'params))
-;; (key ($ 'key))
-;; (params (db:string->obj paramsj transport: 'http))) ;; incoming data from the POST (or is it a GET?)
-;; (debug:print 4 *default-log-port* "cmd:" cmd " with params " params "key " key)
-;; (if (equal? key *server-id*)
-;; (begin
-;; (set! *api-process-request-count* (+ *api-process-request-count* 1))
-;; (let* ((resdat (api:execute-requests dbstruct (vector cmd params))) ;; process the request, resdat = #( flag result )
-;; (success (vector-ref resdat 0))
-;; (res (vector-ref resdat 1))) ;; (vector flag payload), get the payload, ignore the flag (why?)
-;; (debug:print 4 *default-log-port* "res:" res)
-;; (if (not success)
-;; (debug:print 0 *default-log-port* "ERROR: success flag is #f for " cmd " with params " params))
-;; (if (> *api-process-request-count* *max-api-process-requests*)
-;; (set! *max-api-process-requests* *api-process-request-count*))
-;; (set! *api-process-request-count* (- *api-process-request-count* 1))
-;; ;; This can be here but needs controls to ensure it doesn't run more than every 4 seconds
-;; ;; (rmt:dat->json-str
-;; ;; (if (or (string? res)
-;; ;; (list? res)
-;; ;; (number? res)
-;; ;; (boolean? res))
-;; ;; res
-;; ;; (list "ERROR, not string, list, number or boolean" 1 cmd params res)))))
-;; (db:obj->string res transport: 'http)))
-;; (begin
-;; (debug:print 0 *default-log-port* "Server refused to process request. Server id mismatch. recived " key " expected: " *server-id* ".\nOther arguments recived: cmd=" cmd " params = " params)
-;; (db:obj->string (conc "Server refused to process request server-id mismatch: " key ", " *server-id*) transport: 'http)))))
-;;
-;;
Index: items.scm
==================================================================
--- items.scm
+++ items.scm
@@ -21,12 +21,15 @@
;; (temperature "cool medium hot")
;; (season "summer winter fall spring")))
(declare (unit items))
(declare (uses common))
+(declare (uses debugprint))
(include "common_records.scm")
+
+(import debugprint)
;; Puts out all combinations
(define (process-itemlist hierdepth curritemkey itemlist)
(let ((res '()))
(if (not hierdepth)
Index: keys.scm
==================================================================
--- keys.scm
+++ keys.scm
@@ -19,15 +19,19 @@
;;======================================================================
;; Run keys, these are used to hierarchially organise tests and run areas
;;======================================================================
-(use sqlite3 srfi-1 posix regex regex-case srfi-69)
-(import (prefix sqlite3 sqlite3:))
-
(declare (unit keys))
(declare (uses common))
+(declare (uses debugprint))
+
+(use srfi-1 posix regex regex-case srfi-69
+ (prefix sqlite3 sqlite3:))
+
+(import debugprint)
+
(include "key_records.scm")
(include "common_records.scm")
(define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ...
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -32,15 +32,18 @@
(declare (uses subrun))
(declare (uses common))
(declare (uses configf))
(declare (uses db))
(declare (uses ezsteps))
+(declare (uses debugprint))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "megatest-fossil-hash.scm")
+
+(import debugprint)
;;======================================================================
;; ezsteps
;;======================================================================
Index: lock-queue.scm
==================================================================
--- lock-queue.scm
+++ lock-queue.scm
@@ -14,15 +14,17 @@
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
-(use (prefix sqlite3 sqlite3:) srfi-18)
-
(declare (unit lock-queue))
(declare (uses common))
(declare (uses tasks))
+(declare (uses debugprint))
+
+(use (prefix sqlite3 sqlite3:) srfi-18)
+(import debugprint)
;;======================================================================
;; attempt to prevent overlapping updates of rollup files by queueing
;; update requests in an sqlite db
;;======================================================================
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -48,22 +48,24 @@
(declare (uses servermod))
(declare (uses commonmod))
(declare (uses commonmod.import))
(declare (uses dbfile))
(declare (uses dbfile.import))
-;; (declare (uses debugprint))
-;; (declare (uses debugprint.import))
+(declare (uses debugprint))
+(declare (uses debugprint.import))
;; (declare (uses mtargs))
;; (declare (uses mtargs.import))
;; (declare (uses ftail))
;; (import ftail)
(import dbmod
commonmod
dbfile
- servermod)
+ servermod
+ debugprint
+ )
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
(include "key_records.scm")
Index: mlaunch.scm
==================================================================
--- mlaunch.scm
+++ mlaunch.scm
@@ -23,11 +23,11 @@
;; take jobs from the given queue and keep launching them keeping
;; the cpu load at the targeted level
;;
;;======================================================================
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 format)
-
(declare (unit mlaunch))
(declare (uses db))
(declare (uses common))
+
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 format)
DELETED mockup-cached-writes.scm
Index: mockup-cached-writes.scm
==================================================================
--- mockup-cached-writes.scm
+++ /dev/null
@@ -1,48 +0,0 @@
-;; 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 .
-;;
-
-
-(define (make-cached-writer the-db)
- (let ((db the-db)
- (queue '()))
- (lambda (cacheable . qry-params) ;; fn qry
- (if cacheable
- (begin
- (set! queue (cons qry-params queue))
- (call/cc))
- (begin
- (print "Starting transaction")
- (for-each
- (lambda (queue-item)
- (let ((fn (car queue-item))
- (qry (cdr queue-item)))
- (print "WRITE to " db ": " qry)
- )
- (reverse queue))
- (print "End transaction")
- (print "READ from " db ": " qry-params))))))
-
-(define *cw* (make-cached-writer "the db"))
-
-(define (dbcall cacheable query)
- (*cw* cacheable query))
-
-(dbcall #t "insert abc")
-(dbcall #t "insert def")
-(dbcall #t "insert hij")
-(dbcall #f "select foo")
DELETED monitor.scm
Index: monitor.scm
==================================================================
--- monitor.scm
+++ /dev/null
@@ -1,33 +0,0 @@
-;; 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 .
-
-;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking)
-(import (prefix sqlite3 sqlite3:))
-
-(declare (unit runs))
-(declare (uses db))
-(declare (uses common))
-(declare (uses items))
-(declare (uses runconfig))
-
-(include "common_records.scm")
-(include "key_records.scm")
-(include "db_records.scm")
-(include "run_records.scm")
-
Index: mt.scm
==================================================================
--- mt.scm
+++ mt.scm
@@ -28,16 +28,19 @@
(declare (uses tests))
(declare (uses servermod))
(declare (uses runs))
(declare (uses rmtmod))
;; (declare (uses filedb))
+(declare (uses debugprint))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
+
+(import debugprint)
;; This is the Megatest API. All generally "useful" routines will be wrapped or extended
;; here.
;;======================================================================
Index: mtserv.scm
==================================================================
--- mtserv.scm
+++ mtserv.scm
@@ -30,10 +30,11 @@
;; (declare (uses common))
(declare (uses margs))
(declare (uses configfmod))
(declare (uses servermod))
+
(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
(define help (conc "
Index: mtut.scm
==================================================================
--- mtut.scm
+++ mtut.scm
@@ -30,12 +30,15 @@
(declare (uses common))
(declare (uses margs))
(declare (uses configf))
;; (declare (uses rmt))
+(declare (uses debugprint))
(use ducttape-lib)
+
+(import debugprint)
(include "megatest-fossil-hash.scm")
(require-library stml)
Index: newdashboard.scm
==================================================================
--- newdashboard.scm
+++ newdashboard.scm
@@ -36,15 +36,18 @@
;; (declare (uses gutils))
;; (declare (uses db))
;; (declare (uses server))
;; (declare (uses synchash))
(declare (uses dcommon))
+(declare (uses debugprint))
+
;; (declare (uses tree))
;;
;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "key_records.scm")
+(import debugprint)
(define help (conc
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
license GPL, Copyright (C) Matt Welland 2011
Index: portlogger.scm
==================================================================
--- portlogger.scm
+++ portlogger.scm
@@ -22,10 +22,12 @@
(use sqlite3 srfi-1 posix srfi-69 hostinfo dot-locking z3)
(import (prefix sqlite3 sqlite3:))
(declare (unit portlogger))
(declare (uses db))
+(declare (uses debugprint))
+(import debugprint)
;; lsof -i
(define (portlogger:open-db fname)
(let* ((avail (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away
Index: process.scm
==================================================================
--- process.scm
+++ process.scm
@@ -22,10 +22,13 @@
;; Process convience utils
;;======================================================================
(use regex directory-utils)
(declare (unit process))
+(declare (uses debugprint))
+
+(import debugprint)
(define (process:conservative-read port)
(let loop ((res ""))
(if (not (eof-object? (peek-char port)))
(loop (conc res (read-char port)))
Index: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -22,15 +22,18 @@
(declare (unit rmt))
(declare (uses api))
(declare (uses http-transport))
(declare (uses dbfile))
+(declare (uses debugprint))
(include "common_records.scm")
;; (declare (uses rmtmod))
-(import dbfile) ;; rmtmod)
+(import dbfile
+ debugprint
+ ) ;; rmtmod)
;; ;;
;; ;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!
;; ;;
;;
DELETED rmtdb.scm
Index: rmtdb.scm
==================================================================
--- rmtdb.scm
+++ /dev/null
@@ -1,20 +0,0 @@
-;;======================================================================
-;; Copyright 2006-2013, 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 .
-
-;;======================================================================
-
Index: rmtmod.scm
==================================================================
--- rmtmod.scm
+++ rmtmod.scm
@@ -20,25 +20,31 @@
(declare (unit rmtmod))
(declare (uses commonmod))
(declare (uses clientmod))
(declare (uses dbmod))
+(declare (uses debugprint))
+(declare (uses apimod))
(module rmtmod
*
(import scheme
chicken
data-structures
posix
+ ;; regex
srfi-1
srfi-18
srfi-69
extras
-
+
+ commonmod
clientmod
dbmod
+ apimod
+ debugprint
)
;;
;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!
;;
@@ -57,13 +63,15 @@
(define (rmt:get-connection-info areapath) ;; TODO: push areapath down.
(if *runremote*
*runremote*
(begin
(set! *runremote* (client:find-server areapath))
- (con-obj-to-str-set! *runremote* db:obj->str)
+ (con-obj-to-str-set! *runremote* db:obj->string)
+ (con-str-to-obj-set! *runremote* db:string->obj)
(con-host-set! *runremote* (get-host-name))
(con-pid-set! *runremote* (current-process-id))
+ (con-areapath-set! *runremote* areapath)
*runremote*)))
#;(let* ((cinfo (if (remote? runremote)
(remote-conndat runremote)
#f)))
@@ -86,11 +94,11 @@
;;======================================================================
(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)) ;; start attemptnum at 1 so the modulo below works as expected
- (let* ((con (rmt:get-connection-info areapath)))
+ (let* ((con (rmt:get-connection-info *toppath*)))
(client:send-receive con cmd params)))
;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname))
@@ -388,11 +396,11 @@
(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))
+#;(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))
@@ -431,11 +439,11 @@
(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)
+#;(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)))
@@ -464,11 +472,11 @@
(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)
+#;(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
;;
@@ -571,11 +579,11 @@
#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))
+#;(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)
@@ -927,12 +935,12 @@
;;(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)))
+ (let* ((state state-in) ;; (items:check-valid-items "state" state-in))
+ (status status-in)) ;; (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))))
@@ -1035,71 +1043,71 @@
(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)
-
+;;
+;; (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: runconfig.scm
==================================================================
--- runconfig.scm
+++ runconfig.scm
@@ -18,14 +18,16 @@
;;======================================================================
;; read a config file, loading only the section pertinent
;; to this run field1val/field2val/field3val ...
;;======================================================================
-(use format directory-utils)
-
(declare (unit runconfig))
(declare (uses common))
+(declare (uses debugprint))
+
+(use format directory-utils)
+(import debugprint)
(include "common_records.scm")
(define (runconfig:read fname target environ-patt)
(let ((ht (make-hash-table)))
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -29,17 +29,19 @@
(declare (uses tests))
(declare (uses servermod))
(declare (uses mt))
(declare (uses archive))
;; (declare (uses filedb))
+(declare (uses debugprint))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
+(import debugprint)
;; (include "debugger.scm")
;; use this struct to facilitate refactoring
;;
DELETED server.scm
Index: server.scm
==================================================================
--- server.scm
+++ /dev/null
@@ -1,871 +0,0 @@
-;; 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 .
-;;
-
-;; (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))
-;;
-;;
Index: servermod.scm
==================================================================
--- servermod.scm
+++ servermod.scm
@@ -16,10 +16,11 @@
;; along with Megatest. If not, see .
;;======================================================================
(declare (unit servermod))
(declare (uses artifacts))
+(declare (uses debugprint))
(use md5 message-digest posix typed-records extras)
(module servermod
*
@@ -36,10 +37,11 @@
typed-records
data-structures
artifacts
+ debugprint
)
(defstruct srv
(areapath #f)
(host #f)
Index: subrun.scm
==================================================================
--- subrun.scm
+++ subrun.scm
@@ -16,13 +16,10 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
-(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18)
- posix-extras directory-utils pathname-expand typed-records format
- call-with-environment-variables)
(declare (unit subrun))
;;(declare (uses runs))
(declare (uses db))
(declare (uses common))
;;(declare (uses items))
@@ -30,10 +27,17 @@
;;(declare (uses tests))
;;(declare (uses server))
(declare (uses mt))
;;(declare (uses archive))
;; (declare (uses filedb))
+(declare (uses debugprint))
+
+(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18)
+ posix-extras directory-utils pathname-expand typed-records format
+ call-with-environment-variables)
+
+(import debugprint)
;(include "common_records.scm")
;;(include "key_records.scm")
(include "db_records.scm") ;; provides db:test-get-id
;;(include "run_records.scm")
DELETED synchash.scm
Index: synchash.scm
==================================================================
--- synchash.scm
+++ /dev/null
@@ -1,133 +0,0 @@
-;;======================================================================
-;; 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 .
-;;
-;;======================================================================
-
-;;======================================================================
-;; A hash of hashes that can be kept in sync by sending minial deltas
-;;======================================================================
-
-(use format)
-(use srfi-1 srfi-69 sqlite3)
-(import (prefix sqlite3 sqlite3:))
-
-(declare (unit synchash))
-(declare (uses db))
-(declare (uses server))
-(include "db_records.scm")
-
-(define (synchash:make)
- (make-hash-table))
-
-;; given an alist of objects '((id obj) ...)
-;; 1. remove unchanged objects from the list
-;; 2. create a list of removed objects by id
-;; 3. remove removed objects from synchash
-;; 4. replace or add new or changed objects to synchash
-;;
-(define (synchash:get-delta indat synchash)
- (let ((deleted '())
- (changed '())
- (found '())
- (orig-keys (hash-table-keys synchash)))
- (for-each
- (lambda (item)
- (let* ((id (car item))
- (dat (cadr item))
- (ref (hash-table-ref/default synchash id #f)))
- (if (not (equal? dat ref)) ;; item changed or new
- (begin
- (set! changed (cons item changed))
- (hash-table-set! synchash id dat)))
- (set! found (cons id found))))
- indat)
- (for-each
- (lambda (id)
- (if (not (member id found))
- (begin
- (set! deleted (cons id deleted))
- (hash-table-delete! synchash id))))
- orig-keys)
- (list changed deleted)
- ;; (list indat '()) ;; just for debugging
- ))
-
-;; keynum => the field to use as the unique key (usually 0 but can be other field)
-;;
-(define (synchash:client-get proc synckey keynum synchash run-id . params)
- (let* ((data (rmt:synchash-get run-id proc synckey keynum params))
- (newdat (car data))
- (removs (cadr data))
- (myhash (hash-table-ref/default synchash synckey #f)))
- (if (not myhash)
- (begin
- (set! myhash (make-hash-table))
- (hash-table-set! synchash synckey myhash)))
- (for-each
- (lambda (item)
- (let ((id (car item))
- (dat (cadr item)))
- ;; (debug:print-info 2 *default-log-port* "Processing item: " item)
- (hash-table-set! myhash id dat)))
- newdat)
- (for-each
- (lambda (id)
- (hash-table-delete! myhash id))
- removs)
- ;; WHICH ONE!?
- ;; data)) ;; return the changed and deleted list
- (list newdat removs))) ;; synchash))
-
-(define *synchashes* (make-hash-table))
-
-(define (synchash:server-get dbstruct run-id proc synckey keynum params)
- ;; (debug:print-info 2 *default-log-port* "synckey: " synckey ", keynum: " keynum ", params: " params)
- (let* ((dbdat (db:get-db dbstruct run-id))
- (db (db:dbdat-get-db dbdat))
- (synchash (hash-table-ref/default *synchashes* synckey #f))
- (newdat (apply (case proc
- ((db:get-runs) db:get-runs)
- ((db:get-tests-for-run-mindata) db:get-tests-for-run-mindata)
- ((db:get-test-info-by-ids) db:get-test-info-by-ids)
- (else
- (print "ERROR: sync for hash " proc " not setup! Edits needed in synchash.scm")
- print))
- db params))
- (postdat #f)
- (make-indexed (lambda (x)
- (list (vector-ref x keynum) x))))
- ;; Now process newdat based on the query type
- (set! postdat (case proc
- ((db:get-runs)
- ;; (debug:print-info 2 *default-log-port* "Get runs call")
- (let ((header (vector-ref newdat 0))
- (data (vector-ref newdat 1)))
- ;; (debug:print-info 2 *default-log-port* "header: " header ", data: " data)
- (cons (list "header" header) ;; add the header keyed by the word "header"
- (map make-indexed data)))) ;; add each element keyed by the keynum'th val
- (else
- ;; (debug:print-info 2 *default-log-port* "Non-get runs call")
- (map make-indexed newdat))))
- ;; (debug:print-info 2 *default-log-port* "postdat: " postdat)
- ;; (if (not indb)(sqlite3:finalize! db))
- (if (not synchash)
- (begin
- (set! synchash (make-hash-table))
- (hash-table-set! *synchashes* synckey synchash)))
- (synchash:get-delta postdat synchash)))
-
DELETED task_records.scm
Index: task_records.scm
==================================================================
--- task_records.scm
+++ /dev/null
@@ -1,44 +0,0 @@
-;;======================================================================
-;; 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 .
-;;======================================================================
-
-;; make-vector-record tasks task id action owner state target name test item params creation_time execution_time
-(define (make-tasks:task)(make-vector 11))
-(define-inline (tasks:task-get-id vec) (vector-ref vec 0))
-(define-inline (tasks:task-get-action vec) (vector-ref vec 1))
-(define-inline (tasks:task-get-owner vec) (vector-ref vec 2))
-(define-inline (tasks:task-get-state vec) (vector-ref vec 3))
-(define-inline (tasks:task-get-target vec) (vector-ref vec 4))
-(define-inline (tasks:task-get-name vec) (vector-ref vec 5))
-(define-inline (tasks:task-get-testpatt vec) (vector-ref vec 6))
-(define-inline (tasks:task-get-keylock vec) (vector-ref vec 7))
-(define-inline (tasks:task-get-params vec) (vector-ref vec 8))
-(define-inline (tasks:task-get-creation_time vec) (vector-ref vec 9))
-(define-inline (tasks:task-get-execution_time vec) (vector-ref vec 10))
-
-(define-inline (tasks:task-set-state! vec val)(vector-set! vec 3 val))
-
-
-;; make-vector-record tasks monitor id pid start_time last_update hostname username
-(define (make-tasks:monitor)(make-vector 5))
-(define-inline (tasks:monitor-get-id vec) (vector-ref vec 0))
-(define-inline (tasks:monitor-get-pid vec) (vector-ref vec 1))
-(define-inline (tasks:monitor-get-start_time vec) (vector-ref vec 2))
-(define-inline (tasks:monitor-get-last_update vec) (vector-ref vec 3))
-(define-inline (tasks:monitor-get-hostname vec) (vector-ref vec 4))
-(define-inline (tasks:monitor-get-username vec) (vector-ref vec 5))
Index: tasks.scm
==================================================================
--- tasks.scm
+++ tasks.scm
@@ -25,15 +25,17 @@
(declare (uses dbfile))
(declare (uses db))
(declare (uses rmtmod))
(declare (uses common))
(declare (uses pgdb))
+(declare (uses debugprint))
-(import dbfile)
+(import dbfile
+ debugprint
+ )
;; (import pgdb) ;; pgdb is a module
-(include "task_records.scm")
(include "db_records.scm")
;;======================================================================
;; Tasks db
;;======================================================================
Index: tdb.scm
==================================================================
--- tdb.scm
+++ tdb.scm
@@ -32,15 +32,18 @@
(declare (uses keys))
(declare (uses ods))
(declare (uses clientmod))
(declare (uses mt))
(declare (uses db))
+(declare (uses debugprint))
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")
+
+(import debugprint)
;;======================================================================
;;
;; T E S T D A T A B A S E S
;;
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -32,10 +32,13 @@
(declare (uses items))
(declare (uses runconfig))
;; (declare (uses sdb))
(declare (uses servermod))
;;(declare (uses stml2))
+(declare (uses debugprint))
+
+(import debugprint)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
(import (prefix sqlite3 sqlite3:))
(import commonmod)
(require-library stml)
Index: tree.scm
==================================================================
--- tree.scm
+++ tree.scm
@@ -33,15 +33,18 @@
(declare (uses gutils))
(declare (uses db))
;; (declare (uses server))
;; (declare (uses synchash))
(declare (uses dcommon))
+(declare (uses debugprint))
(include "megatest-version.scm")
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
+
+(import debugprint)
;;======================================================================
;; T R E E S T U F F
;;======================================================================