Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -24,16 +24,16 @@ SRCFILES = common.scm items.scm launch.scm ods.scm runconfig.scm \ server.scm configf.scm db.scm keys.scm margs.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ http-transport.scm tdb.scm client.scm mt.scm \ ezsteps.scm lock-queue.scm rmt.scm api.scm \ - subrun.scm portlogger.scm archive.scm env.scm \ + subrun.scm archive.scm env.scm \ diff-report.scm cgisetup/models/pgdb.scm # module source files MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm \ - tcp-transportmod.scm rmtmod.scm + tcp-transportmod.scm rmtmod.scm portlogger.scm all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut tcmt transport-mode.scm : transport-mode.scm.template cp transport-mode.scm.template transport-mode.scm @@ -43,14 +43,21 @@ megatest.scm : transport-mode.scm dashboard.scm : dashboard-transport-mode.scm # dbmod.import.o is just a hack here -mofiles/dbfile.o : mofiles/debugprint.o mofiles/commonmod.o dbmod.import.o +mofiles/portlogger.o : mofiles/dbmod.o + +mofiles/dbfile.o : \ + mofiles/debugprint.o mofiles/commonmod.o + configf.o : commonmod.import.o -db.o : dbmod.import.o +mofiles/dbfile.o : mofiles/debugprint.o +mofiles/rmtmod.o mofiles/dbmod.o : mofiles/dbfile.o +db.o : mofiles/dbmod.o mofiles/dbfile.o mofiles/debugprint.o : mofiles/mtargs.o +mofiles/tcp-transportmod.o : mofiles/portlogger.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 @@ -74,12 +81,12 @@ # @[ -e mofiles ] || mkdir -p mofiles # csc $(CSCOPTS) -I mofiles -I $* -J -c $< -o $*.o # cp $*.o mofiles/$*.o # @touch $*.import.scm # ensure it is touched after the .o is made -mofiles/%.o : %.scm - mkdir -p mofiles +%.import.scm mofiles/%.o : %.scm + @mkdir -p mofiles csc $(CSCOPTS) -J -c $< -o mofiles/$*.o ADTLSCR=mt_laststep mt_runstep mt_ezstep HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR)) DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR)) @@ -129,11 +136,10 @@ launch.o \ lock-queue.o \ margs.o \ mt.o \ ods.o \ - portlogger.o \ process.o \ rmt.o \ runconfig.o \ runs.o \ server.o \ @@ -189,12 +195,13 @@ runs.o : test_records.scm mofiles-made : $(MOFILES) make $(MOIMPFILES) + touch mofiles-made -megatest.o : mofiles-made megatest-fossil-hash.scm megatest-version.scm $(MOFILES) $(MOIMPFILES) +megatest.o : megatest-fossil-hash.scm megatest-version.scm $(MOFILES) $(MOIMPFILES) rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm megatest-version.scm common_records.scm : altdb.scm Index: dbmod.scm ================================================================== --- dbmod.scm +++ dbmod.scm @@ -535,8 +535,40 @@ ;;====================================================================== ;; Moved from dbfile ;;====================================================================== + +;; wait up to aprox n seconds for a journal to go away +;; +(define (tasks:wait-on-journal path n #!key (remove #f)(waiting-msg #f)) + (if (not (string? path)) + (debug:print-error 0 *default-log-port* "Called tasks:wait-on-journal with path=" path " (not a string)") + (let ((fullpath (conc path "-journal"))) + (handle-exceptions + exn + (begin + (print-call-chain (current-error-port)) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 5 *default-log-port* " exn=" (condition->list exn)) + (debug:print 0 *default-log-port* "tasks:wait-on-journal failed. Continuing on, you can ignore this call-chain") + #t) ;; if stuff goes wrong just allow it to move on + (let loop ((journal-exists (file-exists? fullpath)) + (count n)) ;; wait ten times ... + (if journal-exists + (begin + (if (and waiting-msg + (eq? (modulo n 30) 0)) + (debug:print 0 *default-log-port* waiting-msg)) + (if (> count 0) + (begin + (thread-sleep! 1) + (loop (file-exists? fullpath) + (- count 1))) + (begin + (debug:print 0 *default-log-port* "ERROR: removing the journal file " fullpath ", this is not good. Look for disk full, write access and other issues.") + (if remove (system (conc "rm -rf " fullpath))) + #f))) + #t)))))) ) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -53,10 +53,12 @@ (declare (uses db)) (declare (uses dbfile)) (declare (uses dbfile.import)) (declare (uses dbmod)) (declare (uses dbmod.import)) +(declare (uses portlogger)) +(declare (uses portlogger.import)) (declare (uses tcp-transportmod)) (declare (uses tcp-transportmod.import)) (declare (uses rmtmod)) (declare (uses rmtmod.import)) @@ -69,10 +71,11 @@ (import (prefix mtargs args:) debugprint dbmod commonmod dbfile + portlogger tcp-transportmod rmtmod ) (define *db* #f) ;; this is only for the repl, do not use in general!!!! Index: portlogger.scm ================================================================== --- portlogger.scm +++ portlogger.scm @@ -15,25 +15,28 @@ ;; ;; 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 sqlite3 srfi-1 posix srfi-69 hostinfo dot-locking z3) -(import (prefix sqlite3 sqlite3:)) (declare (unit portlogger)) (declare (uses debugprint)) -(declare (uses db)) +(declare (uses dbmod)) + +(module portlogger +* -(import debugprint) +(import scheme chicken data-structures) +(import srfi-1 posix srfi-69 hostinfo dot-locking z3 + (srfi 18) extras tcp s11n) +(import (prefix sqlite3 sqlite3:)) +(import debugprint dbmod) ;; 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 - (exists (common:file-exists? fname)) + (exists (file-exists? fname)) (db (if avail (sqlite3:open-database fname) (begin (system (conc "rm -f " fname)) (sqlite3:open-database fname)))) @@ -46,12 +49,11 @@ ;; port INTEGER PRIMARY KEY, ;; state TEXT DEFAULT 'not-used', ;; fail_count INTEGER DEFAULT 0, ;; update_time TIMESTAMP DEFAULT (strftime('%s','now')) );")))) (sqlite3:set-busy-handler! db handler) - (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") - ;; (if (not exists) ;; needed with IF NOT EXISTS? + (sqlite3:execute db "PRAGMA synchronous = 0;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS ports ( port INTEGER PRIMARY KEY, state TEXT DEFAULT 'not-used', @@ -67,11 +69,11 @@ (begin ;; (release-dot-lock fname) (debug:print-error 0 *default-log-port* "portlogger:open-run-close failed. " proc " " params) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) ;; (debug:print 5 *default-log-port* "exn=" (condition->list exn)) - (if (common:file-exists? fname)(delete-file fname)) ;; brutally get rid of it + (if (file-exists? fname)(delete-file fname)) ;; brutally get rid of it (print-call-chain (current-error-port))) (let* (;; (lock (obtain-dot-lock fname 2 9 10)) (db (portlogger:open-db fname)) (res (apply proc db params))) (sqlite3:finalize! db) @@ -124,17 +126,12 @@ (or curr var curr)) #f db "SELECT (port) FROM ports WHERE state='released' LIMIT 1;"))) -(define (portlogger:find-port db) - (let* ((lowport (let ((val (configf:lookup *configdat* "server" "lowport"))) - (if (and val - (string->number val)) - (string->number val) - 32768))) - (portnum (or (portlogger:get-prev-used-port db) +(define (portlogger:find-port db #!optional (lowport 32768)) + (let* ((portnum (or (portlogger:get-prev-used-port db) (+ lowport ;; top of registered ports is 49152 but lets use ports in the registered range (random (- 64000 lowport)))))) (handle-exceptions exn (begin @@ -186,5 +183,6 @@ ((failed)(portlogger:set-failed db (string->number (cadr args))) 'failed))))) (sqlite3:finalize! db) result)) ;; (print (apply portlogger:main (cdr (argv)))) +) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -43,42 +43,10 @@ ;;====================================================================== ;; Tasks db ;;====================================================================== -;; wait up to aprox n seconds for a journal to go away -;; -(define (tasks:wait-on-journal path n #!key (remove #f)(waiting-msg #f)) - (if (not (string? path)) - (debug:print-error 0 *default-log-port* "Called tasks:wait-on-journal with path=" path " (not a string)") - (let ((fullpath (conc path "-journal"))) - (handle-exceptions - exn - (begin - (print-call-chain (current-error-port)) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 5 *default-log-port* " exn=" (condition->list exn)) - (debug:print 0 *default-log-port* "tasks:wait-on-journal failed. Continuing on, you can ignore this call-chain") - #t) ;; if stuff goes wrong just allow it to move on - (let loop ((journal-exists (common:file-exists? fullpath)) - (count n)) ;; wait ten times ... - (if journal-exists - (begin - (if (and waiting-msg - (eq? (modulo n 30) 0)) - (debug:print 0 *default-log-port* waiting-msg)) - (if (> count 0) - (begin - (thread-sleep! 1) - (loop (common:file-exists? fullpath) - (- count 1))) - (begin - (debug:print 0 *default-log-port* "ERROR: removing the journal file " fullpath ", this is not good. Look for disk full, write access and other issues.") - (if remove (system (conc "rm -rf " fullpath))) - #f))) - #t)))))) - (define (tasks:get-task-db-path) (let ((dbdir (or (configf:lookup *configdat* "setup" "monitordir") (configf:lookup *configdat* "setup" "dbdir") (conc (common:get-linktree) "/.db")))) (handle-exceptions Index: tcp-transportmod.scm ================================================================== --- tcp-transportmod.scm +++ tcp-transportmod.scm @@ -21,10 +21,11 @@ (declare (unit tcp-transportmod)) (declare (uses debugprint)) (declare (uses commonmod)) (declare (uses dbfile)) (declare (uses dbmod)) +(declare (uses portlogger)) (use address-info) (module tcp-transportmod * @@ -58,10 +59,11 @@ debugprint commonmod dbfile dbmod + portlogger ) ;;====================================================================== ;; client ;;====================================================================== @@ -236,32 +238,21 @@ (debug:print 0 *default-log-port* "INFO: no ping response from server "host":"port" for "dbfname) (if (and (file-exists? servinf) (> (- (current-seconds)(file-modification-time servinf)) 60)) (begin (debug:print 0 *default-log-port* "INFO: "servinf" file seems old and no ping response, removing it.") - (delete-file* servinf)))) + (handle-exceptions + exn + #f + (delete-file* servinf))))) (debug:print 0 *default-log-port* "INFO: connection to server "host":"port" broken for "dbfname", but do not see servinf file "servinf)) (tt:handler ttdat cmd run-id params (+ attemptnum 1) area-dat areapath readonly-mode dbfname testsuite mtexe)) (assert #f "FATAL: tt:handler received bad data "res))))) (begin (thread-sleep! 1) ;; give it a rest and try again (tt:handler ttdat cmd run-id params attemptnum area-dat areapath readonly-mode dbfname testsuite mtexe))))) - ;; no conn yet, find and or start and find a server -;; (let* ((server (tt:find-server ttdat dbfname))) -;; (if server -;; (let* ((conn (tt:client-connect-to-server server))) -;; (hash-table-set! (tt-conns ttdat) dbfname conn) -;; (tt:handler ttdat cmd run-id params attemptnum area-dat areapath readonly-mode -;; dbfname testsuite mtexe)) -;; ;; no server, try to start a server process -;; (begin -;; (tt:server-process-run areapath testsuite mtexe run-id) ;; #!key (profile-mode "")) -;; (thread-sleep! 1) -;; (tt:handler ttdat cmd run-id params attemptnum area-dat areapath -;; readonly-mode dbfname testsuite mtexe))))))) - (define (tt:bid-for-servership run-id) #f) ;; gets server info and appends path to server file ;; sorts by age, oldest first @@ -501,12 +492,14 @@ ;; (tcp-close (udat-socket uconn))) ;; ;; (define (tt:shutdown-server ttdat) - (let* ((cleanproc (tt-cleanup-proc ttdat))) + (let* ((cleanproc (tt-cleanup-proc ttdat)) + (port (tt-port ttdat))) (tt-state-set! ttdat 'shutdown) + (portlogger:open-run-close portlogger:set-port port "released") (if cleanproc (cleanproc)) (tcp-close (tt-socket ttdat)) ;; close up ports here )) ;; (define (wait-and-close uconn) @@ -661,10 +654,23 @@ (begin (thread-sleep! 0.25) (setup-listener uconn (+ port 1))) #f) (connect-listener uconn port))) + +(define (setup-listener-portlogger uconn) + (let ((port (portlogger:open-run-close portlogger:find-port))) + (assert (tt? uconn) "FATAL: setup-listener called with wrong struct "uconn) + (handle-exceptions + exn + (if (< port 65535) + (begin + (portlogger:open-run-close portlogger:set-failed port) + (thread-sleep! 0.25) + (setup-listener uconn (portlogger:open-run-close portlogger:find-port))) + #f) + (connect-listener uconn port)))) (define (connect-listener uconn port) ;; (tcp-listener-socket LISTENER)(socket-name so) ;; sockaddr-address, sockaddr-port, sockaddr->string (let* ((tlsn (tcp-listen port 1000 #f)) ;; (tcp-listen TCPPORT [BACKLOG [HOST]])