Bad logic on re-calc of prereq needed. The (runs:testdat-prereqs-not-met testdat) is telling you that this needs recalc as it was previously not met. Thus can bypass if *was* met previously (although why would we reach here if it was met previously?).
Closed-Leaf
check-in: 4e90b83f0b user: matt tags: v1.65-big-refactor(unpublished)
;;======================================================================
;; 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
;; save all stats
(let ((delta-t (- (current-milliseconds)
start-t)))
(hash-table-set! *db-api-call-time* cmd
(cons delta-t (hash-table-ref/default *db-api-call-time* cmd '()))))
(if writecmd-in-readonly-mode
(begin
(common:telemetry-log (conc "api-out:"(->string cmd))
#;(common:telemetry-log (conc "api-out:"(->string cmd))
payload: `((params . ,params)
(ok-res . #t)))
(vector #f res))
(begin
(common:telemetry-log (conc "api-out:"(->string cmd))
#;(common:telemetry-log (conc "api-out:"(->string cmd))
payload: `((params . ,params)
(ok-res . #f)))
(vector #t res))))))))
;; 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
(set! *api-process-request-count* (+ *api-process-request-count* 1))
(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?)
(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?)
(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)))
(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*)
(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. Sever 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)))))
(include-paths (args:get-arg "-include"))
(exclude-pattern (args:get-arg "-exclude-rx"))
(exclude-file (args:get-arg "-exclude-rx-from")))
(if (not archive-timestamp-dir)
(debug:print-error 0 *default-log-port* "Archive not found for testsuite" (common:get-testsuite-name) " run/test/itempath" test-partial-path)
(begin
;; some sanity checks, move an existing path out of the way - iif it is not a toplevel with children
(debug:print-info 0 *default-log-port* "Archive time: " archive-timestamp-dir)
(if (and (not toplevel/children) ;; special handling needed for toplevel with children
prev-test-physical-path
(common:file-exists? prev-test-physical-path)) ;; what to do? abort or clean up or link it in?
(let* ((base (pathname-directory prev-test-physical-path))
(dirn (pathname-file prev-test-physical-path))
(newn (conc base "/." dirn)))
(debug:print-error 0 *default-log-port* "the old directory " prev-test-physical-path ", still exists! Moving it to " newn)
(lambda (a b)
(< (hash-table-ref all-files a)(hash-table-ref all-files b))))
(- num-logs max-allowed))))
(for-each
(lambda (file)
(let* ((fullname (conc "logs/" file)))
(if (directory? fullname)
(debug:print-error 0 *default-log-port* fullname " in logs directory is a directory! Cannot rotate it, it is best to not put subdirectories in the logs dir.")
(debug:print-info 0 *default-log-port* fullname " in logs directory is a directory! Cannot rotate it, it is best to not put subdirectories in the logs dir.")
(handle-exceptions
exn
(debug:print-error 0 *default-log-port* "failed to remove " fullname ", exn=" exn)
(delete-file* fullname)))))
files)
(debug:print-info 0 *default-log-port* "Deleted " (length files) " files from logs, keeping " max-allowed " files."))))))
id INTEGER PRIMARY KEY,
test_id INTEGER,
state TEXT DEFAULT 'new',
status TEXT DEFAULT 'n/a',
archive_type TEXT DEFAULT 'bup',
du INTEGER,
archive_path TEXT);")))
(print "creating trigges from init")
;; (print "creating trigges from init")
(db:create-triggers db)
db)) ;; )
;;======================================================================
;; A R C H I V E S
;;======================================================================
;; ;; (db:general-call dbdat 'state-status-msg (list state status msg test-id))
;; ;; (db:general-call dbdat 'state-status (list state status test-id)))
;; (db:set-state-status-and-roll-up-items dbstruct run-id test-id #f state status msg)
;; ;; process the test_data table
;; (if (and test-id state status (equal? status "AUTO"))
;; (db:test-data-rollup dbstruct run-id test-id status))
;; (mt:process-triggers dbstruct run-id test-id state status)))
;; NOT FINISHED
(define (db:calc-state-status-toplevel state status tl-state tl-status)
`(,state ,status))
;; (match state
;; (("COMPLETED")
;; (match `(,tl-state ,tl-status)
;; (("COMPLETED" "PASS") `(,state ,status))
;; (("COMPLETED" thestatus)
;; (case (string->symbol thestatus)
;; ((ABORT CHECK DEAD)
;; (if `("COMPLETED" ,thestatus))
;; (match `(,thestatus ,status)
;; (("FAIL" "ABORT") '("COMPLETED" "ABORT"))
;; (("FAIL" "CHECK") '("COMPLETED" "CHECK"))
;; (("FAIL" "DEAD") '("COMPLETED" "DEAD"))
;; (("WARN" "FAIL") '("COMPLETED" "FAIL"))
;; (("WARN" "CHECK") '("COMPLETED" "CHECK"))
;; (("WARN" "DEAD")
(define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment)
;; establish info on incoming test followed by info on top level test
;; BBnote - for mode itemwait, linkage between upstream test & matching item status is propagated to run queue in db:prereqs-not-met
;; (mutex-lock! *db-transaction-mutex*) ;; why do we need a mutex?
(let* ((testdat (if (number? test-name)
(db:get-test-info-by-id dbstruct run-id test-name) ;; test-name is actually a test-id
(db:get-test-info dbstruct run-id test-name item-path)))
(test-id (db:test-get-id testdat))
(test-name (if (number? test-name)
(db:test-get-testname testdat)
test-name))
(no-sync-db (db:no-sync-db #f))
(rollup-flag #f)
(wait-flag #f)
(rollup-lock-key (conc run-id "-rollup-" test-name))
(waiting-lock-key (conc run-id "-waiting-" test-name)))
(db:test-set-state-status dbstruct run-id test-id state status #f)
(if (and test-id state status (equal? status "AUTO"))
(db:test-data-rollup dbstruct run-id test-id status))
(if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
(db:general-call dbstruct 'set-test-start-time (list test-id)))
(if (not (equal? item-path "")) ;; only roll up IF incoming test is an item
(begin
;; is there a rollup lock? If not, take it
(sqlite3:with-transaction
no-sync-db
(lambda ()
;; (debug:print 0 *default-log-port* "EXCEPTION: exn="exn)
(let* ((rollup-lock-time (db:no-sync-get/default no-sync-db rollup-lock-key #f))
(waiting-lock-time (db:no-sync-get/default no-sync-db waiting-lock-key #f)))
(if rollup-lock-time ;; someone is doing a rollup
(if (not waiting-lock-time) ;; no one is waiting
(begin
(set! wait-flag #t)
(set! rollup-flag #t)
(db:no-sync-set no-sync-db waiting-lock-key (current-seconds)))) ;; we are going to wait
(begin
(set! rollup-flag #t)
(db:no-sync-set no-sync-db rollup-lock-key (current-seconds)))))))
(if wait-flag
(let loop ((count 10)) ;; about 20 seconds
(thread-sleep! 2)
(if (and (not (db:no-sync-get/default no-sync-db waiting-lock-key #f))
(> count 0))
(loop (+ count 1))
(sqlite3:with-transaction
no-sync-db
(lambda ()
(db:no-sync-set no-sync-db rollup-lock-key (current-seconds))
(db:no-sync-del! no-sync-db waiting-lock-key))))))
;; now the rollup
(if rollup-flag ;; put this into a thread
(begin
;; (thread-start! (make-thread
;; (lambda ()
(db:roll-up-test-state-status dbstruct run-id test-name state status)
(db:no-sync-del! no-sync-db rollup-lock-key))
;; (conc "thread for run-id: " run-id " test-name: " test-name))))))))
)))))
;; I'd like to remove the need for item-path - it is logically not needed here
;; for now we pass in state and status - NOTE: There is a possible race if a test
;; is rapidly re-run while an earlier run is waiting to rollup.
;;
(define (db:roll-up-test-state-status dbstruct run-id test-name state status)
(let* ((testdat (if (number? test-name)
(db:get-test-info-by-id dbstruct run-id test-name) ;; test-name is actually a test-id
(db:get-test-info dbstruct run-id test-name "")))
(test-id (db:test-get-id testdat))
(test-name (if (number? test-name)
(db:test-get-testname testdat)
test-name))
(tl-testdat (db:get-test-info dbstruct run-id test-name ""))
(tl-test-id (db:test-get-id tl-testdat)))
(db:with-db
dbstruct #f #f
(lambda (db)
;; NB// Pass the db so it is part fo the transaction
;; item-path is used in get-all-state-status counts to exclude current state/status of THIS test
;; but with the state/status being set earlier this is not needed any longer
(let* ((state-status-counts (db:get-all-state-status-counts-for-testname dbstruct run-id test-name))
(state-statuses (if (null? state-status-counts)
'()
(db:roll-up-rules state-status-counts state status)))
(newstate (if (null? state-statuses)
state
(car state-statuses)))
(newstatus (if (null? state-statuses)
status
(cadr state-statuses))))
(if tl-test-id
(db:test-set-state-status db run-id tl-test-id newstate newstatus #f))
)))
#t))
;; state is the priority rollup of all states
;; status is the priority rollup of all completed statesfu
;;
;; if test-name is an integer work off that instead of test-name test-path
;;
(define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment)
(define (db:set-state-status-and-roll-up-items-orig dbstruct run-id test-name item-path state status comment)
;; establish info on incoming test followed by info on top level test
;; BBnote - for mode itemwait, linkage between upstream test & matching item status is propagated to run queue in db:prereqs-not-met
(let* ((testdat (if (number? test-name)
(db:get-test-info-by-id dbstruct run-id test-name) ;; test-name is actually a test-id
(db:get-test-info dbstruct run-id test-name item-path)))
(test-id (db:test-get-id testdat))
(test-name (if (number? test-name)
(nonmatch-countrec-lambda (lambda (countrec) (not (match-countrec-lambda countrec))))
(unrelated-rec-list
(filter nonmatch-countrec-lambda other-items-count-recs)))
(cons updated-count-rec unrelated-rec-list)))
;; full count not including toplevel
;;
(define (db:get-all-state-status-counts-for-testname dbstruct run-id test-name)
(let* ((test-count-recs (db:with-db
dbstruct #f #f
(lambda (db)
(sqlite3:map-row
(lambda (state status count)
(make-dbr:counts state: state status: status count: count))
db
"SELECT state,status,count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' GROUP BY state,status;"
run-id test-name)))))
test-count-recs))
;; (define (db:get-all-item-states db run-id test-name)
;; (sqlite3:map-row
;; (lambda (a) a)
;; db
;; "SELECT DISTINCT state FROM tests WHERE item_path != '' AND state != 'DELETED' AND run_id=? AND testname=?"
;; run-id test-name))
<div class="imageblock">
<div class="content">
<img src="megatest-system-architecture.png" alt="Static">
</div>
</div>
</div>
</div>
</div>
<div class="sect1">
<h2 id="_road_map">Road Map</h2>
<div class="sectionbody">
</div>
</div>
<div class="sect1">
<h2 id="_todo_road_map">TODO / Road Map</h2>
<div class="sectionbody">
<div class="paragraph"><p>Note: This road-map is a wish list and not a formal plan. Items are in
rough priority but are subject to change. Development is driven by
user requests, developer "itch" and bug reports. Please contact
</div>
<div class="sect1">
<h2 id="_installation">Installation</h2>
<div class="sectionbody">
<div class="sect2">
<h3 id="_dependencies">Dependencies</h3>
<div class="paragraph"><p>Chicken scheme and a number of "eggs" are required for building
Megatest. See the script installall.sh in the utils directory of the
source distribution for an automated way to install everything
needed for building Megatest on Linux.</p></div>
Megatest. In the v1.66 and beyond assistance to create the build
<div class="paragraph"><p>Megatest. In the v1.66 and beyond assistance to create the build
system is built into the Makefile.</p></div>
<div class="listingblock">
<div class="title">Installation steps (overview)</div>
<div class="content monospaced">
<pre>./configure
make chicken
setup.sh make -j install</pre>
// This file is part of Megatest.
//
// Megatest is free software: you can redistribute it and/or modify
// it under the terms of the GNU General Public License as published by
// the Free Software Foundation, either version 3 of the License, or
// (at your option) any later version.
//
// Megatest is distributed in the hope that it will be useful,
// but WITHOUT ANY WARRANTY; without even the implied warranty of
// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
// GNU General Public License for more details.
//
// You should have received a copy of the GNU General Public License
// along with Megatest. If not, see <http://www.gnu.org/licenses/>.
// Copyright 2006-2020, Matthew Welland.
Test Plan
---------
Tests
~~~~~
itemwait|33
rerun-downstream-item|20
rerunclean|20
fullrun|18
goodtests|18
kill-rerun|17
items-runconfigvars|16
ro_test|16
runconfig-tests|16
env-pollution|13
itemmap|11
testpatt_envvar|10
toprun|10
chained-waiton|8
skip-on-fileexists|8
killrun_preqfail|7
subrun|6
dependencies|5
itemwait-simple|4
rollup|4
end-of-run|3
killrun|3
listener|3
test2|3
testpatt|3
env-pollution-usecacheno|2
set-values|2
envvars|1
listruns-tests|1
subrun-usecases|1
(http-transport:server-dat-get-api-req serverdat)
(begin
(debug:print 0 *default-log-port* "FATAL ERROR: http-transport:client-api-send-receive called with no server info")
(exit 1))))
(res (vector #f "uninitialized"))
(success #t)
(sparams (db:obj->string params transport: 'http))
(runremote (or area-dat *runremote*)))
(debug:print-info 11 *default-log-port* "fullurl=" fullurl ",cmd=" cmd ", params=" params ", run-id=" run-id "\n") (runremote (or area-dat *runremote*))
(server-id (if (vector? serverdat)
(http-transport:server-dat-get-server-id serverdat)
(begin
(debug:print 0 *default-log-port* "FATAL ERROR: http-transport:client-api-send-receive called with no server info")
(exit 1)))))
(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
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;; Always use two or four digit decimal
;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..
;; (declare (unit megatest-version))
(define megatest-version 1.6566)
(define megatest-version 1.6581)
(if out-file (close-output-port out-port))
(exit) ;; yes, bending the rules here - need to exit since this is a utility
))
(if (args:get-arg "-ping")
(let* ((server-id (string->number (args:get-arg "-ping"))) ;; extract run-id (i.e. no ":"
(host:port (args:get-arg "-ping")))
(server:ping (or server-id host:port) do-exit: #t)))
(server:ping (or server-id host:port) #f do-exit: #t)))
;;======================================================================
;; Capture, save and manipulate environments
;;======================================================================
;; NOTE: Keep these above the section where the server or client code is setup
;; DOT INIT_RUNREMOTE; // leaving off - doesn't really add to the clarity
;; DOT MUTEXLOCK -> INIT_RUNREMOTE [label="no remote?"];
;; DOT INIT_RUNREMOTE -> MUTEXLOCK;
;; ensure we have a record for our connection for given area
(if (not runremote) ;; can remove this one. should never get here.
(begin
(set! *runremote* (make-remote))
(let* ((server-info (remote-server-info *runremote*)))
(if server-info
(begin
(remote-server-url-set! *runremote* (server:record->url server-info))
(remote-server-id-set! *runremote* (server:record->id server-info)))))
(set! runremote *runremote*))) ;; new runremote will come from this on next iteration
;; DOT SET_HOMEHOST; // leaving off - doesn't really add to the clarity
;; DOT MUTEXLOCK -> SET_HOMEHOST [label="no homehost?"];
;; DOT SET_HOMEHOST -> MUTEXLOCK;
;; ensure we have a homehost record
(if (not (pair? (remote-hh-dat runremote))) ;; not on homehost
;;DOT CASE6 [label="init\nremote"];
;;DOT MUTEXLOCK -> CASE6 [label="on homehost,\nwrite query,\nhave server,\ncan't reach it"]; {rank=same "case 6" CASE6};
;;DOT CASE6 -> "rmt:send-receive";
;; on homehost and this is a write, we already have a server, but server has died
((and (cdr (remote-hh-dat runremote)) ;; on homehost
(not (member cmd api:read-only-queries)) ;; this is a write
(remote-server-url runremote) ;; have a server
(not (server:ping (remote-server-url runremote)))) ;; server has died. NOTE: this is not a cheap call! Need better approach.
(not (server:ping (remote-server-url runremote) (remote-server-id runremote)))) ;; server has died. NOTE: this is not a cheap call! Need better approach.
(set! *runremote* (make-remote))
(let* ((server-info (remote-server-info *runremote*)))
(if server-info
(begin
(remote-server-url-set! *runremote* (server:record->url server-info))
(remote-server-id-set! *runremote* (server:record->id server-info)))))
(remote-force-server-set! runremote (common:force-server?))
(mutex-unlock! *rmt-mutex*)
(debug:print-info 12 *default-log-port* "rmt:send-receive, case 6")
(rmt:send-receive cmd rid params attemptnum: attemptnum))
;;DOT CASE7 [label="homehost\nwrite"];
;;DOT MUTEXLOCK -> CASE7 [label="server not required,\non homehost,\na write,\nhave a server"]; {rank=same "case 7" CASE7};
;;DOT CASE8 -> "rmt:open-qry-close-locally";
;; on homehost, no server contact made and this is a write, passively start a server
((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
(cdr (remote-hh-dat runremote)) ;; have homehost
(not (remote-server-url runremote)) ;; no connection yet
(not (member cmd api:read-only-queries))) ;; not a read-only query
(debug:print-info 12 *default-log-port* "rmt:send-receive, case 8")
(let ((server-url (server:check-if-running *toppath*))) ;; (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call
(if server-url (remote-server-url-set! runremote server-url) ;; the string can be consumed by the client setup if needed
(let ((server-info (server:check-if-running *toppath*))) ;; (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call
(if server-info
(begin
(remote-server-url-set! runremote (server:record->url server-info)) ;; the string can be consumed by the client setup if needed
(remote-server-id-set! runremote (server:record->id server-info)))
(if (common:force-server?)
(server:start-and-wait *toppath*)
(server:kind-run *toppath*)))) (server:kind-run *toppath*)))
(remote-force-server-set! runremote (common:force-server?))
(mutex-unlock! *rmt-mutex*)
(debug:print-info 12 *default-log-port* "rmt:send-receive, case 8.1")
(rmt:open-qry-close-locally cmd 0 params))
(rmt:open-qry-close-locally cmd 0 params)))
;;DOT CASE9 [label="force server\nnot on homehost"];
;;DOT MUTEXLOCK -> CASE9 [label="no connection\nand either require server\nor not on homehost"]; {rank=same "case 9" CASE9};
;;DOT CASE9 -> "start\nserver" -> "rmt:send-receive";
((or (and (remote-force-server runremote) ;; we are forcing a server and don't yet have a connection to one
(not (remote-conndat runremote)))
(and (not (cdr (remote-hh-dat runremote))) ;; not on a homehost
;; => review of a previously seen test is higher priority of never visited test
;; reg - list of previously visited tests
;; tal - list of never visited tests
;; prefer next hed to be from reg than tal.
(define runs:nothing-left-in-queue-count 0)
(define (runs:lazy-get-prereqs-not-met testdat run-id waitons hed item-path #!optional (mode '(normal))(itemmaps #f)) ;; mode: testmode itemmaps: itemmaps)
(define (runs:lazy-get-prereqs-not-met testdat run-id waitons hed item-path #!key (mode '(normal))(itemmaps #f)) ;; mode: testmode itemmaps: itemmaps)
(if (and (runs:testdat-prereqs-not-met testdat)
(< (- (current-seconds) (runs:testdat-last-update testdat)) 10)) ;; only refresh for this test if it has been at least 10 seconds
(runs:testdat-prereqs-not-met testdat)
(let* ((res (let ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode: mode itemmaps: itemmaps)))
(let* ((res (let ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode itemmaps)))
(if (list? res)
res
(begin
(debug:print 0 *default-log-port*
"ERROR: rmt:get-prereqs-not-met returned non-list!\n"
" res=" res " run-id=" run-id " waitons=" waitons " hed=" hed " item-path=" item-path " testmode=" mode " itemmaps=" itemmaps)
'())))))
registry-mutex: registry-mutex
flags: flags
keyvals: keyvals
run-info: run-info
;; newtal: newtal
all-tests-registry: all-tests-registry
;; itemmaps: itemmaps
;; prereqs-not-met: (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps) ;; can-run-more-tests: (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs) ;; look at the test jobgroup and tot jobs running
)))
;; Initialize the test-registery hash with tests that already have a record
;; convert state to symbol and use that as the hash value
(for-each (lambda (trec)
(let ((id (db:test-get-id trec))
;; 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)))))))
;; 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)
(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
;; 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 uses match let
;;
(define (server:logf-get-start-info logf)
(let ((rx (regexp "^SERVER STARTED: (\\S+):(\\d+) AT ([\\d\\.]+)"))) ;; SERVER STARTED: host:port AT timesecs
(let ((rx (regexp "^SERVER STARTED: (\\S+):(\\d+) AT ([\\d\\.]+) server-id: (\\S+)"))) ;; SERVER STARTED: host:port AT timesecs server id
(handle-exceptions
exn
(begin
(print "failed to get server info from " logf ", exn=" exn)
(list #f #f #f)) ;; no idea what went wrong, call it a bad server
(list #f #f #f #f)) ;; 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 rx inl)))
(if (not mlst)
(if (< lnum 500) ;; give up if more than 500 lines of server log read
(loop (read-line)(+ lnum 1))
(list #f #f #f))
(list #f #f #f #f))
(let ((dat (cdr mlst)))
(list (car dat) ;; host
(string->number (cadr dat)) ;; port
(string->number (caddr dat))))))
(list #f #f #f))))))))
(string->number (caddr dat))
(cadr (cddr dat))))))
(list #f #f #f #f))))))))
;; get a list of servers 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)))