Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -45,10 +45,11 @@ megatest.scm : transport-mode.scm dashboard.scm : dashboard-transport-mode.scm # dbmod.import.o is just a hack here mofiles/portlogger.o : mofiles/dbmod.o +mofiles/dbfile.o : mofiles/debugprint.o mofiles/commonmod.o mofiles/dbfile.o : \ mofiles/debugprint.o mofiles/commonmod.o configf.o : commonmod.import.o Index: dbfile.scm ================================================================== --- dbfile.scm +++ dbfile.scm @@ -24,31 +24,57 @@ (declare (uses debugprint)) (declare (uses commonmod)) (module dbfile * - - (import scheme - chicken + +(import scheme) +(cond-expand + (chicken-4 + (import chicken data-structures extras - matchable - - (prefix sqlite3 sqlite3:) - posix typed-records - - srfi-18 - srfi-1 - srfi-69 - stack + + posix + files ports - - commonmod - debugprint ) + (define current-process-milliseconds current-milliseconds) + ) + (chicken-5 + (import chicken.base + chicken.condition + chicken.file + chicken.file.posix + chicken.format + chicken.io + chicken.pathname + chicken.port + chicken.process + chicken.process-context.posix + chicken.sort + chicken.string + chicken.time + chicken.time.posix + system-information + ) + (define file-move move-file) + (define file-write-access? file-writable?) + )) + + (import (prefix sqlite3 sqlite3:)) + (import typed-records) + (import srfi-18) + (import srfi-1) + (import srfi-69) + (import stack) + (import commonmod) + (import debugprint) + (import matchable) + ;; parameters ;; (define dbfile:testsuite-name (make-parameter #f)) (define keep-age-param (make-parameter 10)) ;; qif file age, if over move to attic @@ -843,11 +869,11 @@ ;; (dbfile:print-err "db:sync-tables: args are good") (let ((stmts (make-hash-table)) ;; table-field => stmt (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 )) (numrecs (make-hash-table)) - (start-time (current-milliseconds)) + (start-time (current-process-milliseconds)) (tot-count 0)) (for-each ;; table (lambda (tabledat) (let* ((tablename (car tabledat)) (fields (cdr tabledat)) @@ -987,11 +1013,11 @@ (append (list todb) slave-dbs) ) ) ) tbls) - (let* ((runtime (- (current-milliseconds) start-time)) + (let* ((runtime (- (current-process-milliseconds) start-time)) (should-print (or ;; (debug:debug-mode 12) (common:low-noise-print 120 "db sync") (> runtime 500)))) ;; low and high sync times treated as separate. (for-each (lambda (dat) Index: dbmod.scm ================================================================== --- dbmod.scm +++ dbmod.scm @@ -25,26 +25,37 @@ (declare (uses debugprint)) (module dbmod * -(import scheme - chicken - data-structures - extras - - (prefix sqlite3 sqlite3:) - posix - typed-records - srfi-1 - srfi-18 - srfi-69 - - commonmod - dbfile - debugprint - ) +(import scheme) +(cond-expand + (chicken-4 + (import chicken + data-structures + extras + posix + ) + (define current-process-milliseconds current-milliseconds) + ) + (chicken-5 + (import chicken.base + chicken.file + chicken.sort + chicken.string + chicken.time + + ))) + +(import (prefix sqlite3 sqlite3:)) +(import typed-records) +(import srfi-1) +(import srfi-18) +(import srfi-69) +(import commonmod) +(import dbfile) +(import debugprint) ;; NOTE: This returns only the name "1.db", "main.db", not the path ;; (define (dbmod:run-id->dbfname run-id) (conc (dbfile:run-id->dbnum run-id)".db")) @@ -238,11 +249,11 @@ (assert (sqlite3:database? fromdb) "FATAL: dbmod:sync-tables called with fromdb not a database" fromdb) (assert (sqlite3:database? todb) "FATAL: dbmod:sync-tables called with fromdb not a database" todb) (let ((stmts (make-hash-table)) ;; table-field => stmt (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 )) (numrecs (make-hash-table)) - (start-time (current-milliseconds)) + (start-time (current-process-milliseconds)) (tot-count 0)) (for-each ;; table (lambda (tabledat) (let* ((tablename (car tabledat)) (fields (cdr tabledat)) @@ -353,11 +364,11 @@ (sqlite3:finalize! stmth) (if (member "last_update" field-names) (db:create-trigger db tablename))) )) tbls) - (let* ((runtime (- (current-milliseconds) start-time)) + (let* ((runtime (- (current-process-milliseconds) start-time)) (should-print (or ;; (debug:debug-mode 12) (common:low-noise-print 120 "db sync") (> runtime 500)))) ;; low and high sync times treated as separate. (for-each (lambda (dat) @@ -419,11 +430,11 @@ " SELECT * FROM "fromdb table";")) (stmt8 (conc "UPDATE "todb table" SET ("no-id-fields-str") = (SELECT "no-id-fields-str" FROM "fromdb table" WHERE "todb table".id="fromdb table".id" (if (member "last_update" fields) (conc " AND "fromdb table".last_update > "todb table".last_update);") ");"))) - (start-ms (current-milliseconds))) + (start-ms (current-process-milliseconds))) ;; (debug:print 0 *default-log-port* "stmt8="stmt8) ;; (if (sqlite3:auto-committing? dbh) ;; (begin (mutex-lock! *db-transaction-mutex*) (sqlite3:with-transaction @@ -437,11 +448,11 @@ ;; (sqlite3:execute dbh stmt5) ;; (sqlite3:execute dbh stmt4) ;; if it worked this would be better for incremental up ;; (sqlite3:execute dbh stmt6) )) (debug:print 0 *default-log-port* "Synced table "table - " in "(- (current-milliseconds) start-ms)"ms") ;; ) + " in "(- (current-process-milliseconds) start-ms)"ms") ;; ) (mutex-unlock! *db-transaction-mutex*))) ;; (debug:print 0 *default-log-port* "Skipping sync of table "table" due to transaction in flight.")))) table-names) (sqlite3:execute dbh "DETACH auxdb;")))) @@ -510,11 +521,11 @@ ;; (conc " AND "fromdb table".last_update > "todb table".last_update);") ;; ");"))) (stmt1 (conc "SELECT MAX(last_update) FROM "table";")) ;; use the highest last_update as your time reference (stmt2 (conc "SELECT no-id-fields-str FROM "table" WHERE last_update>?;")) (stmt3 (conc "UPDATE "table" SET ("no-id-fields-str") = ("questionmarks") WHERE id=?;")) - (start-ms (current-milliseconds))) + (start-ms (current-process-milliseconds))) (debug:print 0 *default-log-port* "stmt3="stmt3) (if (sqlite3:auto-committing? dbh1) (begin (sqlite3:with-transaction dbh1 @@ -526,11 +537,11 @@ ;; (sqlite3:execute dbh stmt5) ;; (sqlite3:execute dbh stmt4) ;; if it worked this would be better for incremental up ;; (sqlite3:execute dbh stmt6) )) (debug:print 0 *default-log-port* "Synced table "table - " in "(- (current-milliseconds) start-ms)"ms")) + " in "(- (current-process-milliseconds) start-ms)"ms")) (debug:print 0 *default-log-port* "Skipping sync of table "table" due to transaction in flight.")))) table-names) (sqlite3:execute dbh1 "DETACH auxdb;")))) Index: tcp-transportmod.scm ================================================================== --- tcp-transportmod.scm +++ tcp-transportmod.scm @@ -23,48 +23,65 @@ (declare (uses commonmod)) (declare (uses dbfile)) (declare (uses dbmod)) (declare (uses portlogger)) -(use address-info) - (module tcp-transportmod * - (import scheme - (prefix sqlite3 sqlite3:) - chicken +(import scheme) +(cond-expand + (chicken-4 + (import chicken data-structures - - address-info - directory-utils + hostinfo extras files - hostinfo - matchable - md5 - message-digest + directory-utils ports posix - regex - regex-case - s11n - srfi-1 - srfi-18 - srfi-4 - srfi-69 - stack - typed-records - tcp-server - tcp - - debugprint - commonmod - dbfile - dbmod + portlogger + )) + (chicken-5 + (import chicken.base + chicken.condition + chicken.file + chicken.file.posix + chicken.io + chicken.port + chicken.process + chicken.process-context + chicken.process-context.posix + chicken.sort + chicken.string + chicken.time + system-information + socket portlogger - ) + ) + (define unsetenv unset-environment-variable!))) + +(import (prefix sqlite3 sqlite3:)) +(import address-info) +(import matchable) +(import md5) +(import message-digest) +(import regex) +(import regex-case) +(import s11n) +(import srfi-1) +(import srfi-18) +(import srfi-4) +(import srfi-69) +(import stack) +(import typed-records) +(import tcp-server) +(import tcp6) +(import debugprint) +(import commonmod) +(import dbfile) +(import dbmod) ;;====================================================================== ;; client ;;====================================================================== @@ -71,17 +88,17 @@ ;; (define keep-age-param (make-parameter 10)) ;; qif file age, if over move to attic ;; Used ONLY for client ;; (defstruct tt-conn - host - port - host-port - dbfname - server-id - server-start - pid + (host #f) + (port #f) + (host-port #f) + (dbfname #f) + (server-id #f) + (server-start #f) + (pid #f) ) ;; Used for BOTH clients and servers (defstruct tt ;; client related @@ -692,24 +709,39 @@ (lambda () (write (list areapath (current-process-id) (argv))))))) - (define (tt:get-best-guess-address hostname) - (let ((res #f)) - (for-each - (lambda (adr) - (if (not (eq? (u8vector-ref adr 0) 127)) - (set! res adr))) - ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME - (vector->list (hostinfo-addresses (hostname->hostinfo hostname)))) - (string-intersperse - (map number->string - (u8vector->list - (if res res (hostname->ip hostname)))) "."))) - + (cond-expand + (chicken-4 + (let ((res #f)) + (for-each + (lambda (adr) + (if (not (eq? (u8vector-ref adr 0) 127)) + (set! res adr))) + ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME + (vector->list (hostinfo-addresses (hostname->hostinfo hostname)))) + (string-intersperse + (map number->string + (u8vector->list + (if res res (hostname->ip hostname)))) "."))) + (chicken-5 + (let* ((get-first (lambda (str) ;; "1.2.3.4" => 1, but "127.1.2.3 => 0 so it sorts last + (let* ((res (string->number (car (string-split str "."))))) + (if (eq? res 127) + 0 + res)))) + (addresses (sort + (map address-info-host (address-infos hostname)) + (lambda (a b) + (let* ((a-first (get-first a)) + (b-first (get-first b))) + (> a-first b-first)))))) + (car addresses))))) + + (define (tt:get-servinfo-dir areapath) (let* ((spath (conc areapath"/.servinfo"))) (if (not (file-exists? spath)) (create-directory spath #t)) spath))