Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -77,15 +77,18 @@ (debug:print-info 11 "Using transport type of " *transport-type* (if hostinfo (conc " to connect to " hostinfo) "")) (case *transport-type* ((fs) ;; (if (not *megatest-db*)(set! *megatest-db* (open-db)))) ;; we are not doing fs any longer. let's cheat and start up a server - (set! *transport-type* #f) - (system "megatest -list-servers | grep alive || megatest -server - -daemonize && sleep 3") - (thread-sleep! 1) - (if (> numtries 0) - (client:setup numtries: (- numtries 1)))) + ;; if we are falling back on fs (not 100% supported) do an about face and start a server + (if (not (equal? (args:get-arg "-transport") "fs")) + (begin + (set! *transport-type* #f) + (system "megatest -list-servers | grep alive || megatest -server - -daemonize && sleep 3") + (thread-sleep! 1) + (if (> numtries 0) + (client:setup numtries: (- numtries 1)))))) ((http) (http-transport:client-connect (tasks:hostinfo-get-interface hostinfo) (tasks:hostinfo-get-port hostinfo))) ((zmq) (zmq-transport:client-connect (tasks:hostinfo-get-interface hostinfo) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -53,10 +53,11 @@ (define *server-id* #f) (define *server-info* #f) (define *time-to-exit* #f) (define *received-response* #f) (define *default-numtries* 10) +(define *db-write-access* #t) (define *target* (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN (define *keys* (make-hash-table)) ;; cache the keys here (define *keyvals* (make-hash-table)) (define *toptest-paths* (make-hash-table)) ;; cache toptest path settings here Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -68,14 +68,18 @@ (begin (debug:print 0 "ERROR: Attempted to open db when not in megatest area. Exiting.") (exit)))) (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname) (dbexists (file-exists? dbpath)) + (write-access (file-write-access? dbpath)) (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) ;; 136000))) ;; 136000 = 2.2 minutes + (if (and dbexists + (not write-access)) + (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control (debug:print-info 11 "open-db, dbpath=" dbpath " argv=" (argv)) (sqlite3:set-busy-handler! db handler) (if (not dbexists) (db:initialize db)) (db:set-sync db) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -170,11 +170,11 @@ ;; ;; ;; 1 Hello, world! Goodbye Dolly ;; Send msg to serverdat and receive result -(define (http-transport:client-send-receive serverdat msg #!key (numretries 10)) +(define (http-transport:client-send-receive serverdat msg #!key (numretries 30)) (let* (;; (url (http-transport:make-server-url serverdat)) (fullurl (caddr serverdat)) ;; (conc url "/ctrl")) ;; (conc url "/?dat=" msg))) (res #f)) (handle-exceptions exn @@ -208,11 +208,11 @@ (if (not res) (begin (debug:print 0 "WARNING: communication with the server timed out.") (mutex-unlock! *http-mutex*) (http-transport:client-send-receive serverdat msg numretries: (- numretries 1)) - (if (< numtries 3) ;; on last try just exit + (if (< numretries 3) ;; on last try just exit (begin (debug:print 0 "ERROR: communication with the server timed out. Giving up.") (exit 1))))))) (th1 (make-thread send-recieve "with-input-from-request")) (th2 (make-thread time-out "time out"))) Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ ;; Always use two digit decimal ;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.5423) +(define megatest-version 1.5424) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -21,14 +21,18 @@ ;;====================================================================== ;; Tasks db ;;====================================================================== (define (tasks:open-db) - (let* ((dbpath (conc *toppath* "/monitor.db")) - (exists (file-exists? dbpath)) - (mdb (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) - (handler (make-busy-timeout 36000))) + (let* ((dbpath (conc *toppath* "/monitor.db")) + (exists (file-exists? dbpath)) + (write-access (file-write-access? dbpath)) + (mdb (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) + (handler (make-busy-timeout 36000))) + (if (and exists + (not write-access)) + (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control (sqlite3:set-busy-handler! mdb handler) (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;")) (if (not exists) (begin (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY, @@ -105,19 +109,20 @@ )) ;; NB// two servers with same pid on different hosts will be removed from the list if pid: is used! (define (tasks:server-deregister mdb hostname #!key (port #f)(pid #f)(action 'markdead)) (debug:print-info 11 "server-deregister " hostname ", port " port ", pid " pid) - (if pid - (case action - ((delete)(sqlite3:execute mdb "DELETE FROM servers WHERE pid=?;" pid)) - (else (sqlite3:execute mdb "UPDATE servers SET state='dead' WHERE pid=?;" pid))) - (if port - (case action - ((delete)(sqlite3:execute mdb "DELETE FROM servers WHERE hostname=? AND port=?;" hostname port)) - (else (sqlite3:execute mdb "UPDATE servers SET state='dead' WHERE hostname=? AND port=?;" hostname port))) - (debug:print 0 "ERROR: tasks:server-deregister called with neither pid nor port specified")))) + (if *db-write-access* + (if pid + (case action + ((delete)(sqlite3:execute mdb "DELETE FROM servers WHERE pid=?;" pid)) + (else (sqlite3:execute mdb "UPDATE servers SET state='dead' WHERE pid=?;" pid))) + (if port + (case action + ((delete)(sqlite3:execute mdb "DELETE FROM servers WHERE hostname=? AND port=?;" hostname port)) + (else (sqlite3:execute mdb "UPDATE servers SET state='dead' WHERE hostname=? AND port=?;" hostname port))) + (debug:print 0 "ERROR: tasks:server-deregister called with neither pid nor port specified"))))) (define (tasks:server-deregister-self mdb hostname) (tasks:server-deregister mdb hostname pid: (current-process-id))) ;; need a simple call for robustly removing records given host and port