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 "")) +;; stats) +;; " ") +;; "
" (car stat) "" (cadr stat) "
"))) +;; +;; ;; 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 "")) -;; stats) -;; " ") -;; "
" (car stat) "" (cadr stat) "
"))) -;; -;; ;; 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 ;;======================================================================