Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -33,10 +33,15 @@ (declare (uses commonmod)) (import commonmod) (declare (uses dbmod)) (import dbmod) + +(declare (uses rmt)) + +(declare (uses servermod)) +(import servermod) (include "common_records.scm") (include "db_records.scm") ;; client:get-signature @@ -101,21 +106,19 @@ (debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) (if (and (not area-dat) (not *runremote*)) (begin ;; POSSIBLE BUG. I removed the full initialization call. mrw - (set! *runremote* (make-remote)) ;; (create-remote-record)) + (set! *runremote* (create-remote-record)) (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))))))) (if (and host port server-id) - (let* ((start-res (case *transport-type* - ((http)(http-transport:client-connect host port server-id)))) - (ping-res (case *transport-type* - ((http)(rmt:login-no-auto-client-setup start-res))))) + (let* ((start-res (http-transport:client-connect host port server-id)) + (ping-res (rmt:login-no-auto-client-setup start-res))) (if (and start-res ping-res) (let ((runremote (or area-dat *runremote*))) ;; it might have been generated only a few statements ago (remote-conndat-set! runremote start-res) ;; (hash-table-set! runremote run-id start-res) (debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res)) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -43,10 +43,13 @@ (declare (uses configfmod)) (import configfmod) (declare (uses dbmod)) (import dbmod) + +(declare (uses servermod)) +(import servermod) (include "common_records.scm") (include "db_records.scm") (include "js-path.scm") Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -74,15 +74,19 @@ (client:setup areapath) #f)))) (define (create-remote-record) (let ((rr (make-remote))) - (remote-hh-dat-set! rr (common:get-homehost)) ; - (remote-server-info-set! rr (if *toppath* (server:check-if-running *toppath*) #f)) - (remote-transport-set! rr *transport-type*) - (remote-server-timeout-set! rr (server:expiration-timeout)) + (rmt:init-remote rr) rr)) + +(define (rmt:init-remote rr) + (remote-hh-dat-set! rr (common:get-homehost)) ; + (remote-server-info-set! rr (if *toppath* (server:check-if-running *toppath*) #f)) + (remote-transport-set! rr *transport-type*) + (remote-server-timeout-set! rr (server:expiration-timeout)) + rr) ;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname)) ;; (define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -38,10 +38,13 @@ (declare (uses configfmod)) (import configfmod) (declare (uses dbmod)) (import dbmod) + +(declare (uses servermod)) +(import servermod) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") Index: servermod.scm ================================================================== --- servermod.scm +++ servermod.scm @@ -85,36 +85,41 @@ ;; 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-id: (\\S+)"))) ;; SERVER STARTED: host:port AT timesecs server id - (handle-exceptions - exn - (begin - (debug:print-info 0 *default-log-port* "Unable to get server info from " logf ", exn=" exn) - (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)) - (begin - (debug:print-info 0 *default-log-port* "Unable to get server info from first 500 lines of " logf ) - (list #f #f #f #f))) - (let ((dat (cdr mlst))) - (list (car dat) ;; host - (string->number (cadr dat)) ;; port - (string->number (caddr dat)) - (cadr (cddr dat)))))) - (begin - (debug:print-info 0 *default-log-port* "Unable to get server info from " logf " at " (current-seconds)) - (list #f #f #f #f))))))))) + ;;(handle-exceptions + ;; exn + ;; (begin + ;; (debug:print-info 0 *default-log-port* "Unable to get server info from " logf ", exn=" exn) + ;; (list #f #f #f #f)) ;; no idea what went wrong, call it a bad server + (if (and (file-exists? logf) + (file-read-access? logf)) + (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)) + (begin + (debug:print-info 0 *default-log-port* "Unable to get server info from first 500 lines of " logf ) + (list #f #f #f #f))) + (let ((dat (cdr mlst))) + (list (car dat) ;; host + (string->number (cadr dat)) ;; port + (string->number (caddr dat)) + (cadr (cddr dat)))))) + (begin + (debug:print-info 0 *default-log-port* "Unable to get server info from " logf " at " (current-seconds)) + (list #f #f #f #f)))))) + (begin + (debug:print-info 0 *default-log-port* "Unable to get server info from " logf ", file not found or not readable.") + (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)) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -266,30 +266,30 @@ "SELECT count(id) FROM monitors WHERE last_update < (strftime('%s','now') - 300) AND username=?;" (car (user-information (current-user-id)))) res)) ;; -#;(define (tasks:start-monitor db mdb) - (if (> (tasks:get-num-alive-monitors mdb) 2) ;; have two running, no need for more - (debug:print-info 1 *default-log-port* "Not starting monitor, already have more than two running") - (let* ((megatestdb (conc *toppath* "/megatest.db")) - (monitordbf (conc (db:dbfile-path #f) "/monitor.db")) - (last-db-update 0)) ;; (file-modification-time megatestdb))) - (task:register-monitor mdb) - (let loop ((count 0) - (next-touch 0)) ;; next-touch is the time where we need to update last_update - ;; if the db has been modified we'd best look at the task queue - (let ((modtime (file-modification-time megatestdbpath ))) - (if (> modtime last-db-update) - (tasks:process-queue db)) ;; BROKEN. mdb last-db-update megatestdb next-touch)) - ;; WARNING: Possible race conditon here!! - ;; should this update be immediately after the task-get-action call above? - (if (> (current-seconds) next-touch) - (begin - (tasks:monitors-update mdb) - (loop (+ count 1)(+ (current-seconds) 240))) - (loop (+ count 1) next-touch))))))) +;; (define (tasks:start-monitor db mdb) +;; (if (> (tasks:get-num-alive-monitors mdb) 2) ;; have two running, no need for more +;; (debug:print-info 1 *default-log-port* "Not starting monitor, already have more than two running") +;; (let* ((megatestdb (conc *toppath* "/megatest.db")) +;; (monitordbf (conc (db:dbfile-path #f) "/monitor.db")) +;; (last-db-update 0)) ;; (file-modification-time megatestdb))) +;; (task:register-monitor mdb) +;; (let loop ((count 0) +;; (next-touch 0)) ;; next-touch is the time where we need to update last_update +;; ;; if the db has been modified we'd best look at the task queue +;; (let ((modtime (file-modification-time megatestdbpath ))) +;; (if (> modtime last-db-update) +;; (tasks:process-queue db)) ;; BROKEN. mdb last-db-update megatestdb next-touch)) +;; ;; WARNING: Possible race conditon here!! +;; ;; should this update be immediately after the task-get-action call above? +;; (if (> (current-seconds) next-touch) +;; (begin +;; (tasks:monitors-update mdb) +;; (loop (+ count 1)(+ (current-seconds) 240))) +;; (loop (+ count 1) next-touch))))))) ;;====================================================================== ;; T A S K S Q U E U E ;; ;; NOTE:: These operate on task_queue which is in main.db @@ -430,23 +430,23 @@ (db:with-db dbstruct #f #t (lambda (db) (sqlite3:execute db (conc "DELETE FROM tasks_queue WHERE id IN (" task-ids ");"))))) -#;(define (tasks:process-queue dbstruct) - (let* ((task (tasks:snag-a-task dbstruct)) - (action (if task (tasks:task-get-action task) #f))) - (if action (print "tasks:process-queue task: " task)) - (if action - (case (string->symbol action) - ((run) (tasks:start-run dbstruct task)) - ((remove) (tasks:remove-runs dbstruct task)) - ((lock) (tasks:lock-runs dbstruct task)) - ;; ((monitor) (tasks:start-monitor db task)) - #;((rollup) (tasks:rollup-runs dbstruct task)) - ((updatemeta)(tasks:update-meta dbstruct task)) - #;((kill) (tasks:kill-monitors dbstruct task)))))) +;; (define (tasks:process-queue dbstruct) +;; (let* ((task (tasks:snag-a-task dbstruct)) +;; (action (if task (tasks:task-get-action task) #f))) +;; (if action (print "tasks:process-queue task: " task)) +;; (if action +;; (case (string->symbol action) +;; ((run) (tasks:start-run dbstruct task)) +;; ((remove) (tasks:remove-runs dbstruct task)) +;; ((lock) (tasks:lock-runs dbstruct task)) +;; ;; ((monitor) (tasks:start-monitor db task)) +;; #;((rollup) (tasks:rollup-runs dbstruct task)) +;; ((updatemeta)(tasks:update-meta dbstruct task)) +;; #;((kill) (tasks:kill-monitors dbstruct task)))))) (define (tasks:tasks->text tasks) (let ((fmtstr "~10a~10a~10a~12a~20a~12a~12a~10a")) (conc (format #f fmtstr "id" "action" "owner" "state" "target" "runname" "testpatts" "params") "\n" (string-intersperse @@ -505,11 +505,11 @@ (define (tasks:find-task-queue-records dbstruct target run-name test-patt state-patt action-patt) ;; (handle-exceptions ;; exn ;; '() ;; (sqlite3:first-row - (let ((db (db:delay-if-busy (db:get-db dbstruct))) + (let ((db (db:get-db dbstruct)) (res '())) (sqlite3:for-each-row (lambda (a . b) (set! res (cons (cons a b) res))) db "SELECT id,action,owner,state,target,name,testpatt,keylock,params FROM tasks_queue Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -44,10 +44,13 @@ (declare (uses dbmod)) (import dbmod) (declare (uses configfmod)) (import configfmod) + +(declare (uses servermod)) +(import servermod) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm")