Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -24,15 +24,15 @@
SRCFILES = common.scm items.scm launch.scm runconfig.scm \
server.scm configf.scm db.scm margs.scm \
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 \
+ subrun.scm archive.scm env.scm \
diff-report.scm cgisetup/models/pgdb.scm
# module source files
-MSRCFILES = dbmod.scm servermod.scm apimod.scm commonmod.scm rmtmod.scm ods.scm configfmod.scm
+MSRCFILES = dbmod.scm servermod.scm apimod.scm commonmod.scm rmtmod.scm ods.scm configfmod.scm transport.scm portlogger.scm
MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o))
MOIMPFILES = $(MSRCFILES:%.scm=%.import.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 \
@@ -47,11 +47,10 @@
vg.scm
OFILES = $(SRCFILES:%.scm=%.o)
GOFILES = $(GUISRCF:%.scm=%.o)
-
%.import.o : %.import.scm mofiles/%.o
csc $(CSCOPTS) -unit $*.import -c $*.import.scm -o $*.import.o
# I'm not sure the cp is a good idea, changed a lot of things and it may not have been necessary...
# mofiles/%.o %.import.scm : %.scm megatest-fossil-hash.scm
@@ -61,11 +60,11 @@
# ensure import.scm is touched after the .o is made
#
mofiles/%.o %.import.scm : %.scm
- csc $(CSCOPTS) -J -c $< -o mofiles/$*.o
+ csc $(CSCOPTS) -I mofiles -I $* -J -c $< -o mofiles/$*.o
@touch $*.import.scm
ADTLSCR=mt_laststep mt_runstep mt_ezstep
HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR))
DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR))
@@ -115,11 +114,10 @@
items.o \
launch.o \
lock-queue.o \
margs.o \
mt.o \
- portlogger.o \
process.o \
rmt.o \
runconfig.o \
runs.o \
server.o \
@@ -494,12 +492,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 launch.o lock-queue.o margs.o mt.o portlogger.o process.o rmt.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 launch.o lock-queue.o margs.o mt.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
+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 launch.o lock-queue.o margs.o mt.o mofiles/portlogger.o process.o rmt.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 launch.o lock-queue.o margs.o mt.o mofiles/portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.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: build.inc
==================================================================
--- build.inc
+++ build.inc
@@ -1,126 +1,131 @@
# To regenerate this file do:
# (cd utils/;ck52 csc gendeps.scm) && ./utils/gendeps allunits *scm
# cp allunits.inc build.inc
#
-tree.o : mofiles/commonmod.o
-tests.o : mofiles/commonmod.o
-tdb.o : mofiles/commonmod.o
-tcmt.o : mofiles/commonmod.o
-tasks.o : mofiles/commonmod.o
-subrun.o : mofiles/commonmod.o
-mofiles/servermod.o : mofiles/commonmod.o
-server.o : mofiles/commonmod.o
-runs.o : mofiles/commonmod.o
-runconfig.o : mofiles/commonmod.o
-mofiles/rmtmod.o : mofiles/commonmod.o
-rmt.o : mofiles/commonmod.o
-process.o : mofiles/commonmod.o
-portlogger.o : mofiles/commonmod.o
-mofiles/ods.o : mofiles/commonmod.o
-newdashboard.o : mofiles/commonmod.o
-mtut.o : mofiles/commonmod.o
-mt.o : mofiles/commonmod.o
-megatest.o : mofiles/commonmod.o
-lock-queue.o : mofiles/commonmod.o
-launch.o : mofiles/commonmod.o
-items.o : mofiles/commonmod.o
-index-tree.o : mofiles/commonmod.o
-http-transport.o : mofiles/commonmod.o
-genexample.o : mofiles/commonmod.o
-ezsteps.o : mofiles/commonmod.o
-env.o : mofiles/commonmod.o
-diff-report.o : mofiles/commonmod.o
-mofiles/dcommonmod.o : mofiles/commonmod.o
+api.o : mofiles/apimod.o
+api.o : mofiles/commonmod.o
+api.o : mofiles/dbmod.o
+archive.o : mofiles/commonmod.o
+archive.o : mofiles/configfmod.o
+archive.o : mofiles/dbmod.o
+client.o : mofiles/commonmod.o
+client.o : mofiles/dbmod.o
+client.o : mofiles/servermod.o
+common.o : mofiles/commonmod.o
+common.o : mofiles/configfmod.o
+common.o : mofiles/dbmod.o
+common.o : mofiles/servermod.o
+configf.o : mofiles/commonmod.o
+configf.o : mofiles/configfmod.o
+dashboard-context-menu.o : mofiles/commonmod.o
+dashboard-context-menu.o : mofiles/configfmod.o
+dashboard-context-menu.o : mofiles/dbmod.o
+dashboard-guimonitor.o : mofiles/commonmod.o
+dashboard-guimonitor.o : mofiles/dbmod.o
+dashboard-tests.o : mofiles/commonmod.o
+dashboard-tests.o : mofiles/configfmod.o
+dashboard-tests.o : mofiles/dbmod.o
+dashboard.o : mofiles/apimod.o
+dashboard.o : mofiles/commonmod.o
+dashboard.o : mofiles/configfmod.o
+dashboard.o : mofiles/dbmod.o
+dashboard.o : mofiles/dcommonmod.o
+dashboard.o : mofiles/servermod.o
+db.o : mofiles/commonmod.o
+db.o : mofiles/configfmod.o
+db.o : mofiles/dbmod.o
+db.o : mofiles/servermod.o
dcommon.o : mofiles/commonmod.o
-mofiles/dbmod.o : mofiles/commonmod.o
-db.o : mofiles/commonmod.o
-dashboard.o : mofiles/commonmod.o
-dashboard-tests.o : mofiles/commonmod.o
-dashboard-guimonitor.o : mofiles/commonmod.o
-dashboard-context-menu.o : mofiles/commonmod.o
-mofiles/configfmod.o : mofiles/commonmod.o
-configf.o : mofiles/commonmod.o
-common.o : mofiles/commonmod.o
-client.o : mofiles/commonmod.o
-archive.o : mofiles/commonmod.o
-mofiles/apimod.o : mofiles/commonmod.o
-api.o : mofiles/commonmod.o
-tree.o : mofiles/dbmod.o
-tests.o : mofiles/dbmod.o
-tdb.o : mofiles/dbmod.o
-tasks.o : mofiles/dbmod.o
-synchash.o : mofiles/dbmod.o
-subrun.o : mofiles/dbmod.o
-mofiles/servermod.o : mofiles/dbmod.o
-server.o : mofiles/dbmod.o
-runs.o : mofiles/dbmod.o
-mofiles/rmtmod.o : mofiles/dbmod.o
-rmt.o : mofiles/dbmod.o
-portlogger.o : mofiles/dbmod.o
-newdashboard.o : mofiles/dbmod.o
-mt.o : mofiles/dbmod.o
-megatest.o : mofiles/dbmod.o
+dcommon.o : mofiles/configfmod.o
+dcommon.o : mofiles/dbmod.o
+dcommon.o : mofiles/dcommonmod.o
+dcommon.o : mofiles/servermod.o
+diff-report.o : mofiles/commonmod.o
+env.o : mofiles/commonmod.o
+ezsteps.o : mofiles/commonmod.o
+ezsteps.o : mofiles/configfmod.o
+ezsteps.o : mofiles/dbmod.o
+genexample.o : mofiles/commonmod.o
+http-transport.o : mofiles/commonmod.o
+http-transport.o : mofiles/configfmod.o
+http-transport.o : mofiles/dbmod.o
+http-transport.o : mofiles/portlogger.o
+http-transport.o : mofiles/servermod.o
+http-transport.o : mofiles/transport.o
+index-tree.o : mofiles/commonmod.o
+items.o : mofiles/commonmod.o
+items.o : mofiles/configfmod.o
+launch.o : mofiles/commonmod.o
+launch.o : mofiles/configfmod.o
launch.o : mofiles/dbmod.o
-http-transport.o : mofiles/dbmod.o
-ezsteps.o : mofiles/dbmod.o
-dcommon.o : mofiles/dbmod.o
-db.o : mofiles/dbmod.o
-dashboard.o : mofiles/dbmod.o
-dashboard-tests.o : mofiles/dbmod.o
-dashboard-guimonitor.o : mofiles/dbmod.o
-dashboard-context-menu.o : mofiles/dbmod.o
-common.o : mofiles/dbmod.o
-client.o : mofiles/dbmod.o
-archive.o : mofiles/dbmod.o
-api.o : mofiles/dbmod.o
-dcommon.o : mofiles/dcommonmod.o
-dashboard.o : mofiles/dcommonmod.o
-tests.o : mofiles/servermod.o
-server.o : mofiles/servermod.o
-runs.o : mofiles/servermod.o
-rmt.o : mofiles/servermod.o
+lock-queue.o : mofiles/commonmod.o
+megatest.o : mofiles/apimod.o
+megatest.o : mofiles/commonmod.o
+megatest.o : mofiles/configfmod.o
+megatest.o : mofiles/dbmod.o
+megatest.o : mofiles/ods.o
+megatest.o : mofiles/rmtmod.o
megatest.o : mofiles/servermod.o
-http-transport.o : mofiles/servermod.o
-dcommon.o : mofiles/servermod.o
-db.o : mofiles/servermod.o
-dashboard.o : mofiles/servermod.o
-common.o : mofiles/servermod.o
-client.o : mofiles/servermod.o
-tests.o : mofiles/configfmod.o
-tasks.o : mofiles/configfmod.o
-subrun.o : mofiles/configfmod.o
+mofiles/apimod.o : mofiles/commonmod.o
+mofiles/configfmod.o : mofiles/commonmod.o
+mofiles/dbmod.o : mofiles/commonmod.o
+mofiles/dbmod.o : mofiles/configfmod.o
+mofiles/dbmod.o : mofiles/ods.o
+mofiles/dcommonmod.o : mofiles/commonmod.o
+mofiles/dcommonmod.o : mofiles/configfmod.o
+mofiles/ods.o : mofiles/commonmod.o
+mofiles/portlogger.o : mofiles/commonmod.o
+mofiles/portlogger.o : mofiles/configfmod.o
+mofiles/portlogger.o : mofiles/dbmod.o
+mofiles/rmtmod.o : mofiles/apimod.o
+mofiles/rmtmod.o : mofiles/commonmod.o
+mofiles/rmtmod.o : mofiles/dbmod.o
+mofiles/servermod.o : mofiles/commonmod.o
mofiles/servermod.o : mofiles/configfmod.o
-server.o : mofiles/configfmod.o
-runs.o : mofiles/configfmod.o
-rmt.o : mofiles/configfmod.o
-portlogger.o : mofiles/configfmod.o
+mofiles/servermod.o : mofiles/dbmod.o
+mofiles/transport.o : mofiles/commonmod.o
+mofiles/transport.o : mofiles/configfmod.o
+mofiles/transport.o : mofiles/portlogger.o
+mt.o : mofiles/commonmod.o
+mt.o : mofiles/configfmod.o
+mt.o : mofiles/dbmod.o
+mtexec.o : mofiles/configfmod.o
+mtut.o : mofiles/commonmod.o
+mtut.o : mofiles/configfmod.o
+newdashboard.o : mofiles/commonmod.o
newdashboard.o : mofiles/configfmod.o
-mtut.o : mofiles/configfmod.o
-mtexec.o : mofiles/configfmod.o
-mt.o : mofiles/configfmod.o
-megatest.o : mofiles/configfmod.o
-launch.o : mofiles/configfmod.o
-items.o : mofiles/configfmod.o
-http-transport.o : mofiles/configfmod.o
-ezsteps.o : mofiles/configfmod.o
-mofiles/dcommonmod.o : mofiles/configfmod.o
-dcommon.o : mofiles/configfmod.o
-mofiles/dbmod.o : mofiles/configfmod.o
-db.o : mofiles/configfmod.o
-dashboard.o : mofiles/configfmod.o
-dashboard-tests.o : mofiles/configfmod.o
-dashboard-context-menu.o : mofiles/configfmod.o
-configf.o : mofiles/configfmod.o
-common.o : mofiles/configfmod.o
-archive.o : mofiles/configfmod.o
+newdashboard.o : mofiles/dbmod.o
+process.o : mofiles/commonmod.o
+rmt.o : mofiles/apimod.o
+rmt.o : mofiles/commonmod.o
+rmt.o : mofiles/configfmod.o
+rmt.o : mofiles/dbmod.o
+rmt.o : mofiles/rmtmod.o
+rmt.o : mofiles/servermod.o
+runconfig.o : mofiles/commonmod.o
+runs.o : mofiles/commonmod.o
+runs.o : mofiles/configfmod.o
+runs.o : mofiles/dbmod.o
+runs.o : mofiles/servermod.o
+server.o : mofiles/commonmod.o
+server.o : mofiles/configfmod.o
+server.o : mofiles/dbmod.o
+server.o : mofiles/servermod.o
+subrun.o : mofiles/commonmod.o
+subrun.o : mofiles/configfmod.o
+subrun.o : mofiles/dbmod.o
+synchash.o : mofiles/dbmod.o
+tasks.o : mofiles/commonmod.o
+tasks.o : mofiles/configfmod.o
+tasks.o : mofiles/dbmod.o
+tcmt.o : mofiles/commonmod.o
+tdb.o : mofiles/commonmod.o
+tdb.o : mofiles/dbmod.o
tdb.o : mofiles/ods.o
-megatest.o : mofiles/ods.o
-mofiles/dbmod.o : mofiles/ods.o
-mofiles/rmtmod.o : mofiles/apimod.o
-rmt.o : mofiles/apimod.o
-megatest.o : mofiles/apimod.o
-dashboard.o : mofiles/apimod.o
-api.o : mofiles/apimod.o
-rmt.o : mofiles/rmtmod.o
-megatest.o : mofiles/rmtmod.o
+tests.o : mofiles/commonmod.o
+tests.o : mofiles/configfmod.o
+tests.o : mofiles/dbmod.o
+tests.o : mofiles/servermod.o
+tree.o : mofiles/commonmod.o
+tree.o : mofiles/dbmod.o
Index: dbmod.scm
==================================================================
--- dbmod.scm
+++ dbmod.scm
@@ -132,10 +132,46 @@
(debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
(print-call-chain (current-error-port))
default)))
(apply sqlite3:first-result db stmt params)))
+;; 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))))))
+
+;;======================================================================
+;; Megatest databases
+;;======================================================================
+
;; Open the classic megatest.db file (defaults to open in toppath)
;;
;; NOTE: returns a dbdat not a dbstruct!
;;
(define (db:open-megatest-db #!key (path #f)(name #f))
Index: http-transport.scm
==================================================================
--- http-transport.scm
+++ http-transport.scm
@@ -16,26 +16,42 @@
;; along with Megatest. If not, see .
(require-extension (srfi 18) extras tcp s11n)
-(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras)
-
-(use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing)
+(use
+ hostinfo
+ http-client
+ intarweb
+ md5
+ message-digest
+ posix
+ posix-extras
+ regex
+ regex-case
+ spiffy
+ spiffy-directory-listing
+ spiffy-request-vars
+ srfi-1
+ srfi-69
+ uri-common
+ )
;; Configurations for server
(tcp-buffer-size 2048)
(max-connections 2048)
(declare (unit http-transport))
(declare (uses common))
(declare (uses db))
-(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
+;; (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
;; (declare (uses server))
;; (declare (uses daemon))
(declare (uses portlogger))
+(import portlogger)
+
(declare (uses rmt))
(declare (uses commonmod))
(import commonmod)
@@ -45,154 +61,26 @@
(declare (uses dbmod))
(import dbmod)
(declare (uses servermod))
(import servermod)
+
+(declare (uses transport))
+(import transport)
(include "common_records.scm")
(include "db_records.scm")
;; (include "js-path.scm")
;; (require-library stml)
-(define (http-transport:make-server-url hostport)
- (if (not hostport)
- #f
- (conc "http://" (car hostport) ":" (cadr hostport))))
-
-(define *server-loop-heart-beat* (current-seconds))
+;; (define *server-loop-heart-beat* (current-seconds))
;;======================================================================
;; S E R V E R
;; ======================================================================
-;; Call this to start the actual server
-;;
-
-(define *db:process-queue-mutex* (make-mutex))
-
-(define (http-transport:run hostn)
- ;; Configurations for server
- (tcp-buffer-size 2048)
- (max-connections 2048)
- (debug:print 2 *default-log-port* "Attempting to start the server ...")
- (let* ((db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily
- (hostname (get-host-name))
- (ipaddrstr (let ((ipstr (if (string=? "-" hostn)
- ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
- (server:get-best-guess-address hostname)
- #f)))
- (if ipstr ipstr hostn))) ;; hostname)))
- (start-port (portlogger:open-run-close portlogger:find-port))
- (link-tree-path (common:get-linktree))
- (tmp-area (common:get-db-tmp-area))
- (start-file (conc tmp-area "/.server-start")))
- (debug:print-info 0 *default-log-port* "portlogger recommended port: " start-port)
- ;; set some parameters for the server
- (root-path (if link-tree-path
- link-tree-path
- (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP!
- (handle-directory spiffy-directory-listing)
- (handle-exception (lambda (exn chain)
- (signal (make-composite-condition
- (make-property-condition
- 'server
- 'message "server error")))))
-
- ;; http-transport:handle-directory) ;; simple-directory-handler)
- ;; Setup the web server and a /ctrl interface
- ;;
- (vhost-map `(((* any) . ,(lambda (continue)
- ;; open the db on the first call
- ;; This is were we set up the database connections
- (let* (($ (request-vars source: 'both))
- (dat ($ 'dat))
- (res #f))
- (cond
- ((equal? (uri-path (request-uri (current-request)))
- '(/ "api"))
- (send-response body: (api:process-request *dbstruct-db* $) ;; the $ is the request vars proc
- headers: '((content-type text/plain)))
- (mutex-lock! *heartbeat-mutex*)
- (set! *db-last-access* (current-seconds))
- (mutex-unlock! *heartbeat-mutex*))
- ((equal? (uri-path (request-uri (current-request)))
- '(/ ""))
- (send-response body: (http-transport:main-page)))
- ((equal? (uri-path (request-uri (current-request)))
- '(/ "json_api"))
- (send-response body: (http-transport:main-page)))
- ((equal? (uri-path (request-uri (current-request)))
- '(/ "runs"))
- (send-response body: (http-transport:main-page)))
- ((equal? (uri-path (request-uri (current-request)))
- '(/ any))
- (send-response body: "hey there!\n"
- headers: '((content-type text/plain))))
- ((equal? (uri-path (request-uri (current-request)))
- '(/ "hey"))
- (send-response body: "hey there!\n"
- headers: '((content-type text/plain))))
- ((equal? (uri-path (request-uri (current-request)))
- '(/ "jquery3.1.0.js"))
- (send-response body: (http-transport:show-jquery)
- headers: '((content-type application/javascript))))
- ((equal? (uri-path (request-uri (current-request)))
- '(/ "test_log"))
- (send-response body: (http-transport:html-test-log $)
- headers: '((content-type text/HTML))))
- ((equal? (uri-path (request-uri (current-request)))
- '(/ "dashboard"))
- (send-response body: (http-transport:html-dboard $)
- headers: '((content-type text/HTML))))
- (else (continue))))))))
- (handle-exceptions
- exn
- (debug:print 0 *default-log-port* "Failed to create file " start-file ", exn=" exn)
- (with-output-to-file start-file (lambda ()(print (current-process-id)))))
- (http-transport:try-start-server ipaddrstr start-port)))
-
-;; This is recursively run by http-transport:run until sucessful
-;;
-(define (http-transport:try-start-server ipaddrstr portnum)
- (let ((config-hostname (configf:lookup *configdat* "server" "hostname"))
- (config-use-proxy (equal? (configf:lookup *configdat* "client" "use-http_proxy") "yes")))
- (if (not config-use-proxy)
- (determine-proxy (constantly #f)))
- (debug:print-info 0 *default-log-port* "http-transport:try-start-server time=" (seconds->time-string (current-seconds)) " ipaddrsstr=" ipaddrstr " portnum=" portnum " config-hostname=" config-hostname)
- (handle-exceptions
- exn
- (begin
- (print-error-message exn)
- (if (< portnum 64000)
- (begin
- (debug:print 0 *default-log-port* "WARNING: attempt to start server failed. Trying again ...")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (debug:print 5 *default-log-port* "exn=" (condition->list exn))
- (portlogger:open-run-close portlogger:set-failed portnum)
- (debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port")
- (thread-sleep! 0.1)
-
- ;; get_next_port goes here
- (http-transport:try-start-server ipaddrstr
- (portlogger:open-run-close portlogger:find-port)))
- (begin
- (print "ERROR: Tried and tried but could not start the server"))))
- ;; any error in following steps will result in a retry
- (set! *server-info* (list ipaddrstr portnum))
- (debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum)
- ;; This starts the spiffy server
- ;; NEED WAY TO SET IP TO #f TO BIND ALL
- ;; (start-server bind-address: ipaddrstr port: portnum)
- (if config-hostname ;; this is a hint to bind directly
- (start-server port: portnum bind-address: (if (equal? config-hostname "-")
- ipaddrstr
- config-hostname))
- (start-server port: portnum))
- (portlogger:open-run-close portlogger:set-port portnum "released")
- (debug:print 1 *default-log-port* "INFO: server has been stopped"))))
-
;;======================================================================
;; S E R V E R U T I L I T I E S
;;======================================================================
;;======================================================================
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 db))
-
+;; (declare (uses db))
(declare (uses commonmod))
-(import commonmod)
-
(declare (uses configfmod))
-(import configfmod)
-
(declare (uses dbmod))
+
+(module portlogger
+ *
+
+(import scheme chicken data-structures extras ports)
+(import (srfi 18) extras tcp s11n)
+
+(use (prefix sqlite3 sqlite3:) srfi-1 posix srfi-69 hostinfo dot-locking z3)
+
+(import commonmod)
+(import configfmod)
(import dbmod)
;; lsof -i
(define (portlogger:open-db fname)
@@ -193,5 +196,7 @@
((failed)(portlogger:set-failed db (string->number (cadr args))) 'failed)))))
(sqlite3:finalize! db)
result))
;; (print (apply portlogger:main (cdr (argv))))
+
+)
Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -47,11 +47,11 @@
(import servermod)
(include "common_records.scm")
(include "db_records.scm")
-(define *server-loop-heart-beat* (current-seconds))
+;; (define *server-loop-heart-beat* (current-seconds))
;;======================================================================
;; P K T S S T U F F
;;======================================================================
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
ADDED transport.scm
Index: transport.scm
==================================================================
--- /dev/null
+++ transport.scm
@@ -0,0 +1,210 @@
+;;======================================================================
+;; Copyright 2017, 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
+;; 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 .
+
+;;======================================================================
+
+(declare (unit transport))
+(declare (uses commonmod))
+(declare (uses configfmod))
+
+(module transport
+ *
+
+(import commonmod)
+(import configfmod)
+(declare (uses portlogger))
+(declare (uses portlogger.import))
+
+(import portlogger)
+
+(import scheme chicken data-structures extras ports)
+(import
+ (prefix base64 base64:)
+ (prefix sqlite3 sqlite3:)
+ call-with-environment-variables
+ csv
+ csv-xml
+ directory-utils
+ files
+ hostinfo
+ http-client
+ intarweb
+ matchable
+ md5
+ message-digest
+ posix
+ posix-extras
+ regex
+ regex-case
+ s11n
+ spiffy
+ spiffy-directory-listing
+ spiffy-request-vars
+ srfi-1
+ srfi-13
+ srfi-18
+ srfi-69
+ stack
+ tcp
+ typed-records
+ uri-common
+ z3
+ )
+
+(define (http-transport:make-server-url hostport)
+ (if (not hostport)
+ #f
+ (conc "http://" (car hostport) ":" (cadr hostport))))
+
+;;======================================================================
+;; S E R V E R
+;; ======================================================================
+
+;; Call this to start the actual server
+;;
+
+;; (define *db:process-queue-mutex* (make-mutex))
+
+(define (http-transport:run hostn)
+ ;; Configurations for server
+ (tcp-buffer-size 2048)
+ (max-connections 2048)
+ (debug:print 2 *default-log-port* "Attempting to start the server ...")
+ (let* ((db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily
+ (hostname (get-host-name))
+ (ipaddrstr (let ((ipstr (if (string=? "-" hostn)
+ ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
+ (server:get-best-guess-address hostname)
+ #f)))
+ (if ipstr ipstr hostn))) ;; hostname)))
+ (start-port (portlogger:open-run-close
+ (lambda (db)
+ (portlogger:find-port db))))
+ (link-tree-path (common:get-linktree))
+ (tmp-area (common:get-db-tmp-area))
+ (start-file (conc tmp-area "/.server-start")))
+ (debug:print-info 0 *default-log-port* "portlogger recommended port: " start-port)
+ ;; set some parameters for the server
+ (root-path (if link-tree-path
+ link-tree-path
+ (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP!
+ (handle-directory spiffy-directory-listing)
+ (handle-exception (lambda (exn chain)
+ (signal (make-composite-condition
+ (make-property-condition
+ 'server
+ 'message "server error")))))
+
+ ;; http-transport:handle-directory) ;; simple-directory-handler)
+ ;; Setup the web server and a /ctrl interface
+ ;;
+ (vhost-map `(((* any) . ,(lambda (continue)
+ ;; open the db on the first call
+ ;; This is were we set up the database connections
+ (let* (($ (request-vars source: 'both))
+ (dat ($ 'dat))
+ (res #f))
+ (cond
+ ((equal? (uri-path (request-uri (current-request)))
+ '(/ "api"))
+ (send-response body: (api:process-request *dbstruct-db* $) ;; the $ is the request vars proc
+ headers: '((content-type text/plain)))
+ (mutex-lock! *heartbeat-mutex*)
+ (set! *db-last-access* (current-seconds))
+ (mutex-unlock! *heartbeat-mutex*))
+ ;; ((equal? (uri-path (request-uri (current-request)))
+ ;; '(/ ""))
+ ;; (send-response body: (http-transport:main-page)))
+ ;;((equal? (uri-path (request-uri (current-request)))
+ ;; '(/ "json_api"))
+ ;; (send-response body: (http-transport:main-page)))
+ ;;((equal? (uri-path (request-uri (current-request)))
+ ;; '(/ "runs"))
+ ;; (send-response body: (http-transport:main-page)))
+ ;;((equal? (uri-path (request-uri (current-request)))
+ ;; '(/ any))
+ ;; (send-response body: "hey there!\n"
+ ;; headers: '((content-type text/plain))))
+ ;;((equal? (uri-path (request-uri (current-request)))
+ ;; '(/ "hey"))
+ ;; (send-response body: "hey there!\n"
+ ;; headers: '((content-type text/plain))))
+ ;;((equal? (uri-path (request-uri (current-request)))
+ ;; '(/ "jquery3.1.0.js"))
+ ;; (send-response body: (http-transport:show-jquery)
+ ;; headers: '((content-type application/javascript))))
+ ;;((equal? (uri-path (request-uri (current-request)))
+ ;; '(/ "test_log"))
+ ;; (send-response body: (http-transport:html-test-log $)
+ ;; headers: '((content-type text/HTML))))
+ ;;((equal? (uri-path (request-uri (current-request)))
+ ;; '(/ "dashboard"))
+ ;; (send-response body: (http-transport:html-dboard $)
+ ;; headers: '((content-type text/HTML))))
+ (else (continue))))))))
+ (handle-exceptions
+ exn
+ (debug:print 0 *default-log-port* "Failed to create file " start-file ", exn=" exn)
+ (with-output-to-file start-file (lambda ()(print (current-process-id)))))
+ (http-transport:try-start-server ipaddrstr start-port)))
+
+
+;; This is recursively run by http-transport:run until sucessful
+;;
+(define (http-transport:try-start-server ipaddrstr portnum)
+ (let ((config-hostname (configf:lookup *configdat* "server" "hostname"))
+ (config-use-proxy (equal? (configf:lookup *configdat* "client" "use-http_proxy") "yes")))
+ (if (not config-use-proxy)
+ (determine-proxy (constantly #f)))
+ (debug:print-info 0 *default-log-port* "http-transport:try-start-server time=" (seconds->time-string (current-seconds)) " ipaddrsstr=" ipaddrstr " portnum=" portnum " config-hostname=" config-hostname)
+ (handle-exceptions
+ exn
+ (begin
+ (print-error-message exn)
+ (if (< portnum 64000)
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: attempt to start server failed. Trying again ...")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 5 *default-log-port* "exn=" (condition->list exn))
+ (portlogger:open-run-close portlogger:set-failed portnum)
+ (debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port")
+ (thread-sleep! 0.1)
+
+ ;; get_next_port goes here
+ (http-transport:try-start-server ipaddrstr
+ (portlogger:open-run-close portlogger:find-port)))
+ (begin
+ (print "ERROR: Tried and tried but could not start the server"))))
+ ;; any error in following steps will result in a retry
+ (set! *server-info* (list ipaddrstr portnum))
+ (debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum)
+ ;; This starts the spiffy server
+ ;; NEED WAY TO SET IP TO #f TO BIND ALL
+ ;; (start-server bind-address: ipaddrstr port: portnum)
+ (if config-hostname ;; this is a hint to bind directly
+ (start-server port: portnum bind-address: (if (equal? config-hostname "-")
+ ipaddrstr
+ config-hostname))
+ (start-server port: portnum))
+ (portlogger:open-run-close
+ (lambda (db)
+ (portlogger:set-port db portnum "released")))
+ (debug:print 1 *default-log-port* "INFO: server has been stopped"))))
+
+
+)
Index: utils/gendeps.scm
==================================================================
--- utils/gendeps.scm
+++ utils/gendeps.scm
@@ -24,16 +24,19 @@
(define (portprint p . args)
(with-output-to-port p
(lambda ()
(apply print args))))
+(define modules-without-mod
+ "(ods|transport|portlogger)")
+
(define (mofiles-adjust->dot-o inf)
(regex-case
inf
- ("^.*mod$" _ (conc "mofiles/"inf".o"))
- ("ods" _ (conc "mofiles/"inf".o"))
- ("pgdb" _ (conc "cgisetup/models/"inf".o"))
+ ("^.*mod$" _ (conc "mofiles/"inf".o"))
+ (modules-without-mod _ (conc "mofiles/"inf".o"))
+ ("pgdb" _ (conc "cgisetup/models/"inf".o"))
(else (conc inf".o"))))
(define (hh-push ht k1 val)
(hash-table-set! ht k1 (cons val (hash-table-ref/default ht k1 '()))))