Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -27,14 +27,14 @@
process.scm runs.scm tasks.scm tests.scm genexample.scm \
http-transport.scm filedb.scm tdb.scm \
client.scm mt.scm \
ezsteps.scm lock-queue.scm sdb.scm \
rmt.scm api.scm subrun.scm \
- portlogger.scm archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm
+ archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm
# module source files
-MSRCFILES = ftail.scm
+MSRCFILES = ftail.scm portlogger.scm
# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \
@@ -71,11 +71,11 @@
PNGFILES = $(shell cd docs/manual;ls *png)
#all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard
all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut
-mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) mofiles/ftail.o
+mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES)
csc $(CSCOPTS) $(OFILES) $(MOFILES) megatest.o -o mtest
showmtesthash:
@echo $(MTESTHASH)
@@ -83,12 +83,12 @@
csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) -o dboard
ndboard : newdashboard.scm $(OFILES) $(GOFILES)
csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard
-mtut: $(OFILES) megatest-fossil-hash.scm mtut.scm
- csc $(CSCOPTS) $(OFILES) mtut.scm -o mtut
+mtut: $(OFILES) megatest-fossil-hash.scm mtut.scm $(MOFILES)
+ csc $(CSCOPTS) $(OFILES) $(MOFILES) mtut.scm -o mtut
TCMTOBJS = \
api.o \
archive.o \
cgisetup/models/pgdb.o \
@@ -104,25 +104,25 @@
lock-queue.o \
margs.o \
mt.o \
megatest-version.o \
ods.o \
- portlogger.o \
process.o \
rmt.o \
- rpc-transport.o \
runconfig.o \
runs.o \
server.o \
tasks.o \
tdb.o \
tests.o \
subrun.o \
+
+# rpc-transport.o \
+# portlogger.o \
-
-tcmt : $(TCMTOBJS) tcmt.scm
- csc $(CSCOPTS) $(TCMTOBJS) tcmt.scm -o tcmt
+tcmt : $(TCMTOBJS) tcmt.scm $(MOFILES)
+ csc $(CSCOPTS) $(TCMTOBJS) $(MOFILES) tcmt.scm -o tcmt
# install documentation to $(PREFIX)/docs
# DOES NOT REBUILD DOCS
#
$(PREFIX)/share/docs/megatest_manual.html : docs/manual/megatest_manual.html
@@ -156,21 +156,27 @@
megatest.o : megatest-fossil-hash.scm
rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.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
common_records.scm : altdb.scm
vg.o dashboard.o : vg_records.scm
dcommon.o : run_records.scm
+
+# module deps
+http-transport.o : mofiles/portlogger.o
# Temporary while transitioning to new routine
# runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm
megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm
echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new
if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi
$(OFILES) $(GOFILES) : common_records.scm
-%.o : %.scm $(MOFILES)
- csc $(CSCOPTS) -c $< $(MOFILES)
+# %.o : %.scm $(MOFILES)
+# csc $(CSCOPTS) -c $< $(MOFILES)
+
+%.o : %.scm
+ csc $(CSCOPTS) -c $<
$(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest utils/mk_wrapper
@echo Installing to PREFIX=$(PREFIX)
$(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/mtest
utils/mk_wrapper $(PREFIX) mtest $(PREFIX)/bin/megatest
@@ -303,11 +309,11 @@
$(MTQA_FOSSIL) :
fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL)
clean :
- rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o
+ rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o *import.scm
#======================================================================
# Make the records files
#======================================================================
@@ -402,12 +408,12 @@
fi
if csi -ne '(use postgresql)';then \
echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\
fi
-portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
- csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
+portlogger-example : portlogger-example.scm portlogger.o
+ csc $(CSCOPTS) portlogger-example.scm portlogger.o
# create a pdf dot graphviz diagram from notations in rmt.scm
rmt.pdf : rmt.scm
grep ';;DOT' rmt.scm | sed -e 's/.*;;DOT //' > rmt.dot;dot -Tpdf rmt.dot -o rmt.pdf
Index: http-transport.scm
==================================================================
--- http-transport.scm
+++ http-transport.scm
@@ -40,10 +40,15 @@
(include "common_records.scm")
(include "db_records.scm")
(include "js-path.scm")
+(import portlogger)
+(portlogger:set-default-log-port! *default-log-port*)
+(portlogger:set-configdat! *configdat*)
+(portlogger:set-printers! debug:print debug:print-error)
+
(require-library stml)
(define (http-transport:make-server-url hostport)
(if (not hostport)
#f
(conc "http://" (car hostport) ":" (cadr hostport))))
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -53,10 +53,12 @@
(declare (uses tasks)) ;; only used for debugging.
(declare (uses env))
(declare (uses diff-report))
(declare (uses ftail))
(import ftail)
+(declare (uses portlogger))
+(import portlogger)
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
(include "key_records.scm")
@@ -2174,10 +2176,11 @@
(set! *db* dbstruct)
(import extras) ;; might not be needed
;; (import csi)
(import readline)
(import apropos)
+ (import portlogger)
;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
(if *use-new-readline*
(begin
(install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines])
Index: mtut.scm
==================================================================
--- mtut.scm
+++ mtut.scm
@@ -492,10 +492,12 @@
(with-input-from-string
data
(lambda ()
(read))))
+;; moved to portlogger - TODO: remove from here and get from portlogger
+;;
(define (is-port-in-use port-num)
(let* ((ret #f))
(let-values (((inp oup pid)
(process "netstat" (list "-tulpn" ))))
(let loop ((inl (read-line inp)))
Index: portlogger-example.scm
==================================================================
--- portlogger-example.scm
+++ portlogger-example.scm
@@ -15,7 +15,15 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
(declare (uses portlogger))
+(import portlogger)
+(use trace (prefix sqlite3 sqlite3:))
+(trace
+ portlogger:open-db
+ portlogger:take-port
+ portlogger:open-run-close
+ sqlite3:execute
+ )
(print (apply portlogger:main (cdr (argv))))
Index: portlogger.scm
==================================================================
--- portlogger.scm
+++ portlogger.scm
@@ -15,42 +15,67 @@
;;
;; 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 db))
+
+(module
+ portlogger
+ (portlogger:set-configdat!
+ portlogger:set-printers!
+ portlogger:set-default-log-port!
+ portlogger:open-db
+ portlogger:open-run-close
+ portlogger:take-port
+ portlogger:get-prev-used-port
+ portlogger:find-port
+ portlogger:set-port
+ portlogger:release-port
+ portlogger:set-failed
+ portlogger:is-port-in-use
+ portlogger:main
+)
+
+(import scheme posix chicken data-structures ports)
+
+(require-extension (srfi 18) extras tcp s11n)
+(use srfi-1 posix srfi-69 hostinfo dot-locking z3 regex)
+(use (prefix sqlite3 sqlite3:))
+(use (prefix mtconfigf configf:))
;; lsof -i
+(define *configdat* #f)
+(define (portlogger:set-configdat! cfgdat)
+ (set! *configdat* cfgdat))
+
+(define (debug:print level port . params)
+ (with-output-to-port
+ port
+ (lambda ()(apply print params))))
+(define debug:print-error debug:print)
+(define *default-log-port* (current-error-port))
+
+(define (portlogger:set-printers! pdebug pdebugerr)
+ (set! debug:print pdebug)
+ (set! debug:print-error pdebugerr))
+(define (portlogger:set-default-log-port! port)
+ (set! *default-log-port* port))
(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))
+ (let* ((avail #t) ;; for now - assume wait on journal not needed (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away
+ (exists (file-exists? fname))
(db (if avail
(sqlite3:open-database fname)
(begin
(system (conc "rm -f " fname))
(sqlite3:open-database fname))))
- (handler (make-busy-timeout 136000))
+ (handler (sqlite3:make-busy-timeout 136000))
(canwrite (file-write-access? fname)))
- ;; (db-init (lambda ()
- ;; (sqlite3:execute
- ;; db
- ;; "CREATE TABLE IF NOT EXISTS ports (
- ;; 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',
@@ -58,19 +83,19 @@
update_time TIMESTAMP DEFAULT (strftime('%s','now')) );")
db))
(define (portlogger:open-run-close proc . params)
(let* ((fname (conc "/tmp/." (current-user-name) "-portlogger.db"))
- (avail (tasks:wait-on-journal fname 10))) ;; wait up to about 10 seconds for the journal to go away
+ (avail #t)) ;; (tasks:wait-on-journal fname 10))) ;; wait up to about 10 seconds for the journal to go away
(handle-exceptions
exn
(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)
@@ -80,13 +105,13 @@
;; (fold-row PROC INIT DATABASE SQL . PARAMETERS)
(define (portlogger:take-port db portnum)
(let* ((qry1 (sqlite3:prepare db "INSERT INTO ports (port,state) VALUES (?,?);"))
(qry2 (sqlite3:prepare db "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;"))
(qry3 (sqlite3:prepare db "SELECT state FROM ports WHERE port=?;"))
- (res (sqlite3:with-transaction
- db
- (lambda ()
+ (res ;; (sqlite3:with-transaction ;; move the transaction up to the find-port call
+ ;; db
+ ;; (lambda ()
;; (fold-row (lambda (var curr) (or var curr)) #f db "SELECT var FROM foo WHERE id=100;")
(let* ((curr #f)
(res #f))
(set! curr (sqlite3:fold-row
(lambda (var curr)
@@ -100,11 +125,11 @@
((not-tried) (sqlite3:execute qry1 portnum "taken") 'taken)
((taken) 'already-taken)
((failed) 'failed)
(else 'error)))
;; (print "res=" res)
- res)))))
+ res))) ;; ))
(sqlite3:finalize! qry1)
(sqlite3:finalize! qry2)
(sqlite3:finalize! qry3)
res))
@@ -124,38 +149,60 @@
#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)
- (+ lowport ;; top of registered ports is 49152 but lets use ports in the registered range
- (random (- 64000 lowport))))))
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (debug:print 5 *default-log-port* "exn=" (condition->list exn))
- (print-call-chain (current-error-port))
- (debug:print 0 *default-log-port* "Continuing anyway."))
- (portlogger:take-port db portnum))
- portnum))
+ (let ((lowport (let ((val (configf:lookup *configdat* "server" "lowport")))
+ (if (and val
+ (string->number val))
+ (string->number val)
+ 32768))))
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (let loop ((numtries 0))
+ (let* ((portnum (or (portlogger:get-prev-used-port db)
+ (+ lowport ;; top of registered ports is 49152 but let's use ports in the registered range
+ (random (- 64000 lowport))))))
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 5 *default-log-port* "exn=" (condition->list exn))
+ (print-call-chain (current-error-port))
+ (debug:print 0 *default-log-port* "Continuing anyway."))
+ (portlogger:take-port db portnum) ;; always "take the port"
+ (if (portlogger:is-port-in-use portnum)
+ portnum
+ (loop (add1 numtries))))))))))
;; set port to "released", "failed" etc.
;;
(define (portlogger:set-port db portnum value)
(sqlite3:execute db "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;" value portnum))
+;; release port
+(define (portlogger:release-port db portnum)
+ (sqlite3:execute db "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;" "released" portnum))
+
;; set port to failed (attempted to take but got error)
;;
(define (portlogger:set-failed db portnum)
(sqlite3:execute db "UPDATE ports SET state='failed',fail_count=fail_count+1,update_time=strftime('%s','now') WHERE port=?;" portnum))
+
+;; pulled from mtut - TODO: remove from mtut
+;;
+(define (portlogger:is-port-in-use port-num)
+ (let-values (((inp oup pid)
+ (process "netstat" (list "-tulpn" ))))
+ (let loop ((inl (read-line inp)))
+ (if (not (eof-object? inl))
+ (begin
+ (if (string-search (regexp (conc ":" port-num "\\s+")) inl)
+ #t
+ (loop (read-line inp))))))))
;;======================================================================
;; MAIN
;;======================================================================
@@ -180,10 +227,12 @@
(state (caddr args)))
(portlogger:set-port db
(if (number? port) port (string->number port))
state)
state))
- ((failed)(portlogger:set-failed db (string->number (cadr args))) 'failed)))))
+ ((failed)(portlogger:set-failed db (string->number (cadr args))) 'failed)
+ (else "nosuchcommand")))))
(sqlite3:finalize! db)
result))
;; (print (apply portlogger:main (cdr (argv))))
+)
ADDED utils/get-procedures.sh
Index: utils/get-procedures.sh
==================================================================
--- /dev/null
+++ utils/get-procedures.sh
@@ -0,0 +1,5 @@
+#!/bin/bash
+
+fname=$1
+
+grep '(define (' $fname | tr '()' ' '|awk '{print $2}'