Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -22,17 +22,21 @@ CSCOPTS= INSTALL=install 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 filedb.scm tdb.scm client.scm mt.scm \ - ezsteps.scm lock-queue.scm sdb.scm rmt.scm api.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 \ diff-report.scm cgisetup/models/pgdb.scm # module source files -MSRCFILES = dbmod.scm +MSRCFILES = dbmod.scm dbfile.scm debugprint.scm mtargs.scm + +mofiles/dbfile.o : mofiles/debugprint.o +mofiles/debugprint.o : mofiles/mtargs.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 @@ -162,19 +166,19 @@ monitor.o dashboard.o archive.o megatest.o : db_records.scm megatest-fossil-hash.scm tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o : run_records.scm db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm -db.o api.o : mofiles/dbmod.o +db.o api.o : mofiles/dbmod.o mofiles/dbfile.o mofiles/debugprint.o tests.o tasks.o dashboard-tasks.o : task_records.scm runs.o : test_records.scm megatest.o : megatest-fossil-hash.scm megatest-version.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 megatest-version.scm +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 # mofiles/stml2.o : mofiles/cookie.o # configf.o : mofiles/commonmod.o @@ -455,12 +459,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 mt.o ods.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 keys.o launch.o lock-queue.o margs.o mt.o ods.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 genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.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 genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.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 ADDED attic/filedb.scm Index: attic/filedb.scm ================================================================== --- /dev/null +++ attic/filedb.scm @@ -0,0 +1,255 @@ +;; Copyright 2006-2011, 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 . +;; + +;; (require-extension synch sqlite3 posix srfi-13 srfi-1 utils regex) +(use sqlite3 srfi-1 posix regex srfi-69 srfi-13 posix-extras) +(import (prefix sqlite3 sqlite3:)) + +(declare (unit filedb)) + +(include "fdb_records.scm") +;; (include "settings.scm") + +(define (filedb:open-db dbpath) + (let* ((fdb (make-filedb:fdb)) + (dbexists (common:file-exists? dbpath)) + (db (sqlite3:open-database dbpath))) + (filedb:fdb-set-db! fdb db) + (filedb:fdb-set-dbpath! fdb dbpath) + (filedb:fdb-set-pathcache! fdb (make-hash-table)) + (filedb:fdb-set-idcache! fdb (make-hash-table)) + (filedb:fdb-set-partcache! fdb (make-hash-table)) + (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) + (if (not dbexists) + (begin + (sqlite3:execute db "PRAGMA synchronous = OFF;") + (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id + (sqlite3:execute db "CREATE INDEX name_index ON names (name);") + ;; NB// We store a useful subset of file attributes but do not attempt to store all + (sqlite3:execute db "CREATE TABLE paths (id INTEGER PRIMARY KEY, + path TEXT, + parent_id INTEGER, + mode INTEGER DEFAULT -1, + uid INTEGER DEFAULT -1, + gid INTEGER DEFAULT -1, + size INTEGER DEFAULT -1, + mtime INTEGER DEFAULT -1);") + (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);") + (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT, updated TIMESTAMP);"))) + ;; close the sqlite3 db and open it as needed + (filedb:finalize-db! fdb) + (filedb:fdb-set-db! fdb #f) + fdb)) + +(define (filedb:reopen-db fdb) + (let ((db (sqlite3:open-database (filedb:fdb-get-dbpath fdb)))) + (filedb:fdb-set-db! fdb db) + (sqlite3:set-busy-handler! db (make-busy-timeout 136000)))) + +(define (filedb:finalize-db! fdb) + (sqlite3:finalize! (filedb:fdb-get-db fdb))) + +(define (filedb:get-current-time-string) + (string-chomp (time->string (seconds->local-time (current-seconds))))) + +(define (filedb:get-base-id db path) + (let ((stmt (sqlite3:prepare db "SELECT id FROM bases WHERE base=?;")) + (id-num #f)) + (sqlite3:for-each-row + (lambda (num) (set! id-num num)) stmt path) + (sqlite3:finalize! stmt) + id-num)) + +(define (filedb:get-path-id db path parent) + (let ((stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path=? AND parent_id=?;")) + (id-num #f)) + (sqlite3:for-each-row + (lambda (num) (set! id-num num)) stmt path parent) + (sqlite3:finalize! stmt) + id-num)) + +(define (filedb:add-base db path) + (let ((existing (filedb:get-base-id db path))) + (if existing #f + (begin + (sqlite3:execute db "INSERT INTO bases (base,updated) VALUES (?,?);" path (filedb:get-current-time-string)))))) + +;; index value field notes +;; 0 inode number st_ino +;; 1 mode st_mode bitfield combining file permissions and file type +;; 2 number of hard links st_nlink +;; 3 UID of owner st_uid as with file-owner +;; 4 GID of owner st_gid +;; 5 size st_size as with file-size +;; 6 access time st_atime as with file-access-time +;; 7 change time st_ctime as with file-change-time +;; 8 modification time st_mtime as with file-modification-time +;; 9 parent device ID st_dev ID of device on which this file resides +;; 10 device ID st_rdev device ID for special files (i.e. the raw major/minor number) +;; 11 block size st_blksize +;; 12 number of blocks allocated st_blocks + +(define (filedb:add-path-stat db path parent statinfo) + (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id,mode,uid,gid,size,mtime) VALUES (?,?,?,?,?,?,?);"))) + (sqlite3:execute stmt + path + parent + (vector-ref statinfo 1) ;; mode + (vector-ref statinfo 3) ;; uid + (vector-ref statinfo 4) ;; gid + (vector-ref statinfo 5) ;; size + (vector-ref statinfo 8) ;; mtime + ) + (sqlite3:finalize! stmt))) ;; (filedb:get-current-time-string)))) + +(define (filedb:add-path db path parent) + (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id) VALUES (?,?);"))) + (sqlite3:execute stmt path parent) + (sqlite3:finalize! stmt))) + +(define (filedb:register-path fdb path #!key (save-stat #f)) + (let* ((db (filedb:fdb-get-db fdb)) + (pathcache (filedb:fdb-get-pathcache fdb)) + (stat (if save-stat (file-stat path #t))) + (id (hash-table-ref/default pathcache path #f))) + (if (not db)(filedb:reopen-db fdb)) + (if id id + (let ((plist (string-split path "/"))) + (let loop ((head (car plist)) + (tail (cdr plist)) + (parent 0)) + (let ((id (filedb:get-path-id db head parent)) + (done (null? tail))) + (if id ;; we'll have a id if the path is already registered + (if done + (begin + (hash-table-set! pathcache path id) + id) ;; return the last path id for a result + (loop (car tail)(cdr tail) id)) + (begin ;; add the path and then repeat the loop with the same data + (if save-stat + (filedb:add-path-stat db head parent stat) + (filedb:add-path db head parent)) + (loop head tail parent))))))))) + +(define (filedb:update-recursively fdb path #!key (save-stat #f)) + (let ((p (open-input-pipe (string-append "find -L " path)))) ;; (resolve-pathname path)))) ;; (string-append "find " path)))) + (print "processed 0 files...") + (let loop ((l (read-line p)) + (lc 0)) ;; line count + (if (eof-object? l) + (begin + (print " " lc " files") + (close-input-port p)) + (begin + (filedb:register-path fdb l save-stat: save-stat) ;; (get-real-path l)) ;; don't like losing the original path info + (if (= (modulo lc 100) 0) + (print " " lc " files")) + (loop (read-line p)(+ lc 1))))))) + +(define (filedb:update fdb path #!key (save-stat #f)) + ;; first get the realpath and add it to the bases table + (let ((real-path path) ;; (filedb:get-real-path path)) + (db (filedb:fdb-get-db fdb))) + (filedb:add-base db real-path) + (filedb:update-recursively fdb path save-stat: save-stat))) + +;; not used and broken +;; +(define (filedb:get-real-path path) + (let* ((p (open-input-pipe (string-append real-path " " (regexp-escape path)))) + (pth (read-line p))) + (if (eof-object? pth) path + (begin + (close-input-port p) + pth)))) + +(define (filedb:drop-base fdb path) + (print "Sorry, I don't do anything yet")) + +(define (filedb:find-all fdb pattern action) + (let* ((db (filedb:fdb-get-db fdb)) + (stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path like ?;")) + (result '())) + (sqlite3:for-each-row + (lambda (num) + (action num) + (set! result (cons num result))) stmt pattern) + (sqlite3:finalize! stmt) + result)) + +(define (filedb:get-path-record fdb id) + (let* ((db (filedb:fdb-get-db fdb)) + (partcache (filedb:fdb-get-partcache fdb)) + (dat (hash-table-ref/default partcache id #f))) + (if dat dat + (let ((stmt (sqlite3:prepare db "SELECT path,parent_id FROM paths WHERE id=?;")) + (result #f)) + (sqlite3:for-each-row + (lambda (path parent_id)(set! result (list path parent_id))) stmt id) + (hash-table-set! partcache id result) + (sqlite3:finalize! stmt) + result)))) + +(define (filedb:get-children fdb parent-id) + (let* ((db (filedb:fdb-get-db fdb)) + (res '())) + (sqlite3:for-each-row + (lambda (id path parent-id) + (set! res (cons (vector id path parent-id) res))) + db "SELECT id,path,parent_id FROM paths WHERE parent_id=?;" + parent-id) + res)) + +;; retrieve all that have children and those without +;; children that match patt +(define (filedb:get-children-patt fdb parent-id search-patt) + (let* ((db (filedb:fdb-get-db fdb)) + (res '())) + ;; first get the children that have no children + (sqlite3:for-each-row + (lambda (id path parent-id) + (set! res (cons (vector id path parent-id) res))) + db "SELECT id,path,parent_id FROM paths WHERE parent_id=? AND + (id IN (SELECT parent_id FROM paths) OR path LIKE ?);" + parent-id search-patt) + res)) + +(define (filedb:get-path fdb id) + (let* ((db (filedb:fdb-get-db fdb)) + (idcache (filedb:fdb-get-idcache fdb)) + (path (hash-table-ref/default idcache id #f))) + (if (not db)(filedb:reopen-db fdb)) + (if path path + (let loop ((curr-id id) + (path "")) + (let ((path-record (filedb:get-path-record fdb curr-id))) + (if (not path-record) #f ;; this id has no path + (let* ((parent-id (list-ref path-record 1)) + (pname (list-ref path-record 0)) + (newpath (string-append "/" pname path))) + (if (= parent-id 0) ;; fields 0=path, 1=parent. root parent=0 + (begin + (hash-table-set! idcache id newpath) + newpath) + (loop parent-id newpath))))))))) + +(define (filedb:search db pattern) + (let ((action (lambda (id)(print (filedb:get-path db id))))) + (filedb:find-all db pattern action))) + ADDED attic/ftail.scm Index: attic/ftail.scm ================================================================== --- /dev/null +++ attic/ftail.scm @@ -0,0 +1,108 @@ +;;====================================================================== +;; 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 ftail)) + +(module ftail + ( + open-tail-db + tail-write + tail-get-fid + file-tail + ) + +(import scheme chicken data-structures extras) +(use (prefix sqlite3 sqlite3:) posix typed-records) + +(define (open-tail-db ) + (let* ((basedir (create-directory (conc "/tmp/" (current-user-name)))) + (dbpath (conc basedir "/megatest_logs.db")) + (dbexists (file-exists? dbpath)) + (db (sqlite3:open-database dbpath)) + (handler (sqlite3:make-busy-timeout 136000))) + (sqlite3:set-busy-handler! db handler) + (sqlite3:execute db "PRAGMA synchronous = 0;") + (if (not dbexists) + (begin + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_files (id INTEGER PRIMARY KEY,filename TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_data (id INTEGER PRIMARY KEY,fid INTEGER,line TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));") + )) + db)) + +(define (tail-write db fid lines) + (sqlite3:with-transaction + db + (lambda () + (for-each + (lambda (line) + (sqlite3:execute db "INSERT INTO log_data (fid,line) VALUES (?,?);" fid line)) + lines)))) + +(define (tail-get-fid db fname) + (let ((fid (handle-exceptions + exn + #f + (sqlite3:first-result db "SELECT id FROM log_files WHERE filename=?;" fname)))) + (if fid + fid + (begin + (sqlite3:execute db "INSERT INTO log_files (filename) VALUES (?);" fname) + (tail-get-fid db fname))))) + +(define (file-tail fname #!key (db-in #f)) + (let* ((inp (open-input-file fname)) + (db (or db-in (open-tail-db))) + (fid (tail-get-fid db fname))) + (let loop ((inl (read-line inp)) + (lines '()) + (lastwr (current-seconds))) + (if (eof-object? inl) + (let ((timed-out (> (- (current-seconds) lastwr) 60))) + (if timed-out (tail-write db fid (reverse lines))) + (sleep 1) + (if timed-out + (loop (read-line inp) '() (current-seconds)) + (loop (read-line inp) lines lastwr))) + (let* ((savelines (> (length lines) 19))) + ;; (print inl) + (if savelines (tail-write db fid (reverse lines))) + (loop (read-line inp) + (if savelines + '() + (cons inl lines)) + (if savelines + (current-seconds) + lastwr))))))) + +;; offset -20 means get last 20 lines +;; +(define (tail-get-lines db fid offset count) + (if (> offset 0) + (sqlite3:map-row (lambda (id line) + (vector id line)) + db + "SELECT id,line FROM log_data WHERE fid=? OFFSET ? LIMIT ?;" fid offset count) + (reverse ;; get N from the end + (sqlite3:map-row (lambda (id line) + (vector id line)) + db + "SELECT id,line FROM log_data WHERE fid=? ORDER BY id DESC LIMIT ?;" fid (abs offset))))) + +) ADDED attic/sdb.scm Index: attic/sdb.scm ================================================================== --- /dev/null +++ attic/sdb.scm @@ -0,0 +1,116 @@ +;;====================================================================== +;; Copyright 2006-2013, 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 . + +;;====================================================================== + +;;====================================================================== +;; Simple persistant strings lookup table. Keep out of the main db +;; so writes/reads don't slow down central access. +;;====================================================================== + +(require-extension (srfi 18) extras) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) +(import (prefix sqlite3 sqlite3:)) +(import (prefix base64 base64:)) + +(declare (unit sdb)) + +;; +(define (sdb:open fname) + (let* ((dbpath (pathname-directory fname)) + (dbexists (let ((fe (common:file-exists? fname))) + (if fe + fe + (begin + (create-directory dbpath #t) + #f)))) + (sdb (sqlite3:open-database fname)) + (handler (make-busy-timeout 136000))) + (sqlite3:set-busy-handler! sdb handler) + (if (not dbexists) + (sdb:initialize sdb)) + (sqlite3:execute sdb "PRAGMA synchronous = 1;") + sdb)) + +(define (sdb:initialize sdb) + (sqlite3:execute sdb "CREATE TABLE IF NOT EXISTS strs + (id INTEGER PRIMARY KEY, + str TEXT, + CONSTRAINT str UNIQUE (str));") + (sqlite3:execute sdb "CREATE INDEX IF NOT EXISTS strindx ON strs (str);")) + +;; (define sumup (let ((a 0))(lambda (x)(set! a (+ x a)) a))) + +(define (sdb:register-string sdb str) + (sqlite3:execute sdb "INSERT OR IGNORE INTO strs (str) VALUES (?);" str)) + +(define (sdb:string->id sdb str-cache str) + (let ((id (hash-table-ref/default str-cache str #f))) + (if (not id) + (sqlite3:for-each-row + (lambda (sid) + (set! id sid) + (hash-table-set! str-cache str id)) + sdb + "SELECT id FROM strs WHERE str=?;" str)) + id)) + +(define (sdb:id->string sdb id-cache id) + (let ((str (hash-table-ref/default id-cache id #f))) + (if (not str) + (sqlite3:for-each-row + (lambda (istr) + (set! str istr) + (hash-table-set! id-cache id str)) + sdb + "SELECT str FROM strs WHERE id=?;" id)) + str)) + +;; Numbers get passed though in both directions +;; +(define (make-sdb:qry fname) + (let ((sdb #f) + (scache (make-hash-table)) + (icache (make-hash-table))) + (lambda (cmd var) + (case cmd + ((setup) (set! sdb (if (not sdb) + (sdb:open (if var var fname))))) + ((setdb) (set! sdb var)) + ((getdb) sdb) + ((finalize) (if sdb + (begin + (sqlite3:finalize! sdb) + (set! sdb #f)))) + ((getid) (let ((id (if (or (number? var) + (string->number var)) + var + (sdb:string->id sdb scache var)))) + (if id + id + (begin + (sdb:register-string sdb var) + (sdb:string->id sdb scache var))))) + ((getstr) (if (or (number? var) + (string->number var)) + (sdb:id->string sdb icache var) + var)) + ((passid) var) + ((passstr) var) + (else #f))))) + ADDED configfmod.scm Index: configfmod.scm ================================================================== --- /dev/null +++ configfmod.scm @@ -0,0 +1,75 @@ +;;====================================================================== +;; 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 configfmod)) +;; (declare (uses mtargs)) +;; (declare (uses debugprint)) +;; (declare (uses keysmod)) + +(module configfmod +* + +(import srfi-1 + +;; scheme +;; +;; big-chicken ;; more of a reminder than anything ... +;; chicken.base +;; chicken.condition +;; chicken.file +;; chicken.io +;; chicken.pathname +;; chicken.port +;; chicken.pretty-print +;; chicken.process +;; chicken.process-context +;; chicken.process-context.posix +;; chicken.sort +;; chicken.string +;; chicken.time +;; chicken.eval +;; +;; debugprint +;; (prefix mtargs args:) +;; pkts +;; keysmod +;; +;; (prefix base64 base64:) +;; (prefix dbi dbi:) +;; (prefix sqlite3 sqlite3:) +;; (srfi 18) +;; directory-utils +;; format +;; matchable +;; md5 +;; message-digest +;; regex +;; regex-case +;; sparse-vectors +;; srfi-1 +;; srfi-13 +;; srfi-69 +;; stack +;; typed-records +;; z3 + + ) +) + ADDED dbfile.scm Index: dbfile.scm ================================================================== --- /dev/null +++ dbfile.scm @@ -0,0 +1,641 @@ +;;====================================================================== +;; 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 dbfile)) +;; (declare (uses debugprint)) +;; (declare (uses commonmod)) + +(module dbfile + * + +(import scheme chicken data-structures extras) +(import (prefix sqlite3 sqlite3:) + posix typed-records srfi-18 + srfi-69 + stack + files + ports + + ;; commonmod + ) + +;; (import debugprint) + +;;====================================================================== +;; R E C O R D S +;;====================================================================== + +;; a single Megatest area with it's multiple dbs is +;; managed in a dbstruct +;; +(defstruct dbr:dbstruct + (areapath #f) + (homehost #f) + (tmppath #f) + (read-only #f) + (subdbs (make-hash-table)) + ) + +;; NOTE: Need one dbr:subdb per main.db, 1.db ... +;; +(defstruct dbr:subdb + (dbname #f) ;; .db/1.db + (mtdbfile #f) ;; mtrah/.db/1.db + (mtdbdat #f) ;; only need one of these for syncing + ;; (dbdats (make-hash-table)) ;; id => dbdat + (tmpdbfile #f) ;; /tmp/.../.db/1.db + ;; (refndbfile #f) ;; /tmp/.../.db/1.db_ref + (dbstack (make-stack)) ;; stack for tmp dbr:dbdat, + (homehost #f) ;; not used yet + (on-homehost #f) ;; not used yet + (read-only #f) + (last-sync 0) + (last-write (current-seconds)) + ) ;; goal is to converge on one struct for an area but for now it is too confusing + +;; need to keep dbhandles and cached statements together +(defstruct dbr:dbdat + (dbfile #f) + (dbh #f) + (stmt-cache (make-hash-table)) + (read-only #f)) + +(define *dbstruct-dbs* #f) +(define *db-access-mutex* (make-mutex)) +(define *no-sync-db* #f) + +(define (dbfile:run-id->key run-id) + (or run-id 'main)) + +(define (db:safely-close-sqlite3-db db stmt-cache #!key (try-num 3)) + (if (<= try-num 0) + #f + (handle-exceptions + exn + (begin + (print "Attempt to safely close sqlite3 db failed. Trying again. exn=" exn) + (thread-sleep! 3) + (sqlite3:interrupt! db) + (db:safely-close-sqlite3-db db stmt-cache try-num: (- try-num 1))) + (if (sqlite3:database? db) + (let* ((stmts (and stmt-cache (hash-table-ref/default stmt-cache db #f)))) + (if stmts (map sqlite3:finalize! (hash-table-values stmts))) + (sqlite3:finalize! db) + #t) + (begin + (dbfile:print-err "db:safely-close-sqlite3-db: " db " is not an sqlite3 db") + #f + ) + )))) + +;; close all opened run-id dbs +(define (db:close-all dbstruct) + (if (dbr:dbstruct? dbstruct) +;; (handle-exceptions +;; exn +;; (begin +;; (debug:print 0 *default-log-port* "WARNING: Finalizing failed, " ((condition-property-accessor 'exn 'message) exn) ", note - exn=" exn) +;; (print-call-chain *default-log-port*)) + ;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server. + (let* ((subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct)))) + (for-each + (lambda (subdb) + (let* ((tdbs (stack->list (dbr:subdb-dbstack subdb))) + (mtdbdat (dbr:dbdat-dbh (dbr:subdb-mtdbdat subdb))) + #;(rdb (dbr:dbdat-dbh (dbr:subdb-refndb subdb)))) + + (map (lambda (dbdat) + (let* ((stmt-cache (dbr:dbdat-stmt-cache dbdat)) + (dbh (dbr:dbdat-dbh dbdat))) + (db:safely-close-sqlite3-db dbh stmt-cache))) + tdbs) + (db:safely-close-sqlite3-db mtdbdat (dbr:dbdat-stmt-cache (dbr:subdb-mtdbdat subdb))) + ;; (if (sqlite3:database? mdb) (sqlite3:finalize! mdb)) + #;(db:safely-close-sqlite3-db rdb #f))) ;; stmt-cache))))) ;; (if (sqlite3:database? rdb) (sqlite3:finalize! rdb)))))) + subdbs) + #t + ) + #f + ) +) + +;; ;; set up a single db (e.g. main.db, 1.db ... etc.) +;; ;; +;; (define (db:setup-db dbstruct areapath run-id) +;; (let* ((dbname (db:run-id->dbname run-id)) +;; (dbstruct (hash-table-ref/default dbstructs dbname #f))) +;; (if dbstruct +;; dbstruct +;; (let* ((dbstruct-new (make-dbr:dbstruct))) +;; (db:open-db dbstruct-new run-id areapath: areapath do-sync: #t) +;; (hash-table-set! dbstructs dbname dbstruct-new) +;; dbstruct-new)))) + +;; ; Returns the dbdat for a particular dbfile inside the area +;; ;; +;; (define (dbr:dbstruct-get-dbdat dbstruct dbfile) +;; (hash-table-ref/default (dbr:dbstruct-dbdats dbstruct) dbfile #f)) +;; +;; (define (dbr:dbstruct-dbdat-put! dbstruct dbfile db) +;; (hash-table-set! (dbr:dbstruct-dbdats dbstruct) dbfile db)) +;; +;; (define (db:run-id->first-num run-id) +;; (let* ((s (number->string run-id)) +;; (l (string-length s))) +;; (substring s (- l 1) l))) + +;; 1234 => 4/1234.db +;; #f => 0/main.db +;; (abandoned the idea of num/db) +;; +(define (dbfile:run-id->path apath run-id) + (conc apath"/"(dbfile:run-id->dbname run-id))) + +(define (db:dbname->path apath dbname) + (conc apath"/"dbname)) + +(define (dbfile:run-id->dbname run-id) + (cond + ((number? run-id) (conc ".db/" (modulo run-id 100) ".db")) + ((not run-id) (conc ".db/main.db")) + (else run-id))) + +;; Make the dbstruct, setup up auxillary db's and call for main db at least once +;; +;; called in http-transport and replicated in rmt.scm for *local* access. +;; +(define (dbfile:setup do-sync areapath tmppath) + (cond + (*dbstruct-dbs* *dbstruct-dbs*);; TODO: when multiple areas are supported, this optimization will be a hazard + (else ;;(common:on-homehost?) + (let* ((dbstruct (make-dbr:dbstruct))) + #;(when (not *toppath*) + (debug:print-info 0 *default-log-port* "in db:setup, *toppath* not set; calling launch:setup") + (launch:setup areapath: areapath)) + (set! *dbstruct-dbs* dbstruct) + (dbr:dbstruct-areapath-set! dbstruct areapath) + (dbr:dbstruct-tmppath-set! dbstruct tmppath) + dbstruct)))) + +#;(define (dbfile:get-subdb dbstruct run-id) + (let* ((res (hash-table-ref/default (dbr:dbstruct-subdbs dbstruct) (dbfile:run-id->key run-id) #f))) + (if res + res + (let* ((newsubdb (make-dbr:subdb))) + (db:open-db newsubdb run-id areapath: (dbr:dbstruct-areapath dbstruct) do-sync: #t) + (hash-table-set! (dbr:dbstruct-subdbs dbstruct) (dbfile:run-id->key run-id) newsubdb) + newsubdb)))) + +(define (dbfile:get-subdb dbstruct run-id) + (let* ((dbfname (dbfile:run-id->dbname run-id))) + (hash-table-ref/default (dbr:dbstruct-subdbs dbstruct) dbfname #f))) + +(define (dbfile:set-subdb dbstruct run-id subdb) + (hash-table-set! (dbr:dbstruct-subdbs dbstruct) (dbfile:run-id->dbname run-id) subdb)) + +;; Get/open a database +;; if run-id => get run specific db +;; if #f => get main db +;; if run-id is a string treat it as a filename +;; if db already open - return inmem +;; if db not open, open inmem, rundb and sync then return inmem +;; inuse gets set automatically for rundb's +;; +(define (dbfile:get-dbdat dbstruct run-id) + (let* ((subdb (dbfile:get-subdb dbstruct run-id))) + (if (stack-empty? (dbr:subdb-dbstack subdb)) + #f + (stack-pop! (dbr:subdb-dbstack subdb))))) + +;; return a previously opened db handle to the stack of available handles +(define (dbfile:add-dbdat dbstruct run-id dbdat) + (let* ((subdb (dbfile:get-subdb dbstruct run-id))) + (stack-push! (dbr:subdb-dbstack subdb) dbdat))) + +;; set up a subdb +;; +(define (dbfile:init-subdb dbstruct run-id init-proc) + (let* ((dbname (dbfile:run-id->dbname run-id)) + (areapath (dbr:dbstruct-areapath dbstruct)) + (tmppath (dbr:dbstruct-tmppath dbstruct)) + (mtdbpath (dbfile:run-id->path areapath run-id)) + (tmpdbpath (dbfile:run-id->path tmppath run-id)) + (mtdbdat (dbfile:open-sqlite3-db mtdbpath init-proc)) + (newsubdb (make-dbr:subdb dbname: dbname + mtdbfile: mtdbpath + tmpdbfile: tmpdbpath + mtdbdat: mtdbdat))) + (dbfile:set-subdb dbstruct run-id newsubdb) + newsubdb)) ;; return the new subdb - but shouldn't really use it + +;; returns dbdat with dbh and dbfilepath +;; 1. if needed setup the subdb for the given run-id +;; 2. if there is no existing db handle in the stack +;; create a new handle and return it (do NOT add +;; it to the stack). +;; +(define (dbfile:open-db dbstruct run-id init-proc) + (let* ((subdb (dbfile:get-subdb dbstruct run-id))) + (if (not subdb) ;; not yet defined + (begin + (dbfile:init-subdb dbstruct run-id init-proc) + (dbfile:open-db dbstruct run-id init-proc)) + (let* ((dbdat (dbfile:get-dbdat dbstruct run-id))) + (if dbdat + dbdat + (let* ((tmppath (dbr:dbstruct-tmppath dbstruct)) + (tmpdbpath (dbfile:run-id->path tmppath run-id))) + (dbfile:open-sqlite3-db tmpdbpath init-proc))))))) + +;; COMBINE dbfile:open-sqlite-db and dbfile:lock-create-open +;; + +;; Open the classic megatest.db file (defaults to open in toppath) +;; +;; NOTE: returns a dbdat not a dbstruct! +;; +(define (dbfile:open-sqlite3-db dbpath init-proc) + (let* ((dbexists (file-exists? dbpath)) + (write-access (file-write-access? dbpath)) + (db (dbfile:cautious-open-database dbpath init-proc))) #;(sqlite3:open-database dbpath) + (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 10000)) + ;; (init-proc db) + (make-dbr:dbdat dbfile: dbpath dbh: db read-only: (not write-access)))) + +(define (dbfile:print-and-exit . params) + (with-output-to-port + (current-error-port) + (lambda () + (apply print params))) + (exit 1)) + +(define (dbfile:print-err . params) + (with-output-to-port + (current-error-port) + (lambda () + (apply print params)))) + +;; open an sql database inside a file lock +;; returns: db existed-prior-to-opening +;; RA => Returns a db handler; sets the lock if opened in writable mode +;; +;; (define *db-open-mutex* (make-mutex)) +;; +#;(define (dbfile:lock-create-open fname initproc) + (let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local + (raw-fname (pathname-file fname)) + (dir-writable (file-write-access? parent-dir)) + (file-exists (file-exists? fname)) + (file-write (if file-exists + (file-write-access? fname) + dir-writable ))) + ;; (mutex-lock! *db-open-mutex*) ;; tried this mutex, not clear it helped. + (if file-write ;; dir-writable + (condition-case + (let* ((lockfname (conc fname ".lock")) + (readyfname (conc parent-dir "/.ready-" raw-fname)) + (readyexists (common:file-exists? readyfname))) + (if (not readyexists) + (common:simple-file-lock-and-wait lockfname)) + (let ((db (sqlite3:open-database fname))) + (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) + (sqlite3:execute db "PRAGMA synchronous = 0;") + (if (not file-exists) + (initproc db)) + (if (not readyexists) + (begin + (common:simple-file-release-lock lockfname) + (with-output-to-file + readyfname + (lambda () + (print "Ready at " + (seconds->year-work-week/day-time + (current-seconds))))))) + db)) + (exn (io-error) (dbfile:print-and-exit "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")) + (exn (corrupt) (dbfile:print-and-exit "ERROR: database " fname " is corrupt. Repair it to proceed.")) + (exn (busy) (dbfile:print-and-exit "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back.")) + (exn (permission)(dbfile:print-and-exit "ERROR: database " fname " has some permissions problem.")) + (exn () (dbfile:print-and-exit "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn)))) + + (condition-case + (begin + (dbfile:print-err "WARNING: opening db in non-writable dir " fname) + (let ((db (sqlite3:open-database fname))) + (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) + (sqlite3:execute db "PRAGMA synchronous = 0;") + ;; (mutex-unlock! *db-open-mutex*) + db)) + (exn (io-error) + (dbfile:print-and-exit + "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")) + (exn (corrupt) + (dbfile:print-and-exit + "ERROR: database " fname " is corrupt. Repair it to proceed.")) + (exn (busy) + (dbfile:print-and-exit + "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back.")) + (exn (permission) + (dbfile:print-and-exit + "ERROR: database " fname " has some permissions problem.")) + (exn () + (dbfile:print-and-exit + "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn)))) + ))) + + +;; This routine creates the db if not already present. It is only called if the db is not already opened +;; +#;(define (db:init-dbstruct dbstruct run-id init-proc #!key (do-sync #t)) + (let* ((subdb (dbfile:get-subdb dbstruct run-id)) + (tmpdb-stack (dbr:subdb-dbstack subdb)) + (max-stale-tmp (dbr:dbstruct-max-stale-secs dbstruct));; (configf:lookup-number *configdat* "server" "filling-db-max-stale-seconds" default: 10)) + (dbpath (dbr:dbstruct-tmppath dbstruct)) ;; (db:dbfile-path)) ;; path to tmp db area + (dbname (dbfile:run-id->dbname run-id)) + (dbexists (file-exists? dbpath)) + (areapath (dbr:dbstruct-areapath dbstruct)) + (mtdbfname (conc areapath "/"dbname)) + (mtdbexists (file-exists? mtdbfname)) + (mtdbmodtime (if mtdbexists (dbfile:lazy-sqlite-db-modification-time mtdbfname) #f)) + (mtdb (db:open-sqlite-db mtdbfname init-proc)) + ;; the reference db for syncing + (refdbfname (conc dbpath "/"dbname"_ref")) + (refndb (db:open-megatest-db refdbfname)) + ;; (mtdbpath (dbr:dbdat-dbfile mtdb)) + ;; the tmpdb + (tmpdbfname (conc dbpath"/"dbname)) ;; /tmp//.db/[main|1,2...].db + (tmpdb (db:open-megatest-db tmpdbfname)) ;; lock-create-open dbpath db:initialize-main-db)) + (dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db"))) + (tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) + + (write-access (file-write-access? mtdbfname)) + + ;; (mtdbmodtime (if mtdbexists + ;; (common:lazy-sqlite-db-modification-time mtdbpath) + ;; #f)) ; moving this before db:open-megatest-db is + ;; called. if wal mode is on -WAL and -shm file get + ;; created with causing the tmpdbmodtime timestamp + ;; always greater than mtdbmodtime (tmpdbmodtime (if + ;; dbfexists (common:lazy-sqlite-db-modification-time + ;; tmpdbfname) #f)) if wal mode is on -WAL and -shm + ;; file get created when db:open-megatest-db is + ;; called. modtimedelta will always be < 10 so db in + ;; tmp not get synced (tmpdbmodtime (if dbfexists + ;; (db:get-last-update-time (car tmpdb)) #f)) (fmt + ;; (file-modification-time tmpdbfname)) + + (modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime)))) + + (when write-access + (sqlite3:execute (dbr:dbdat-dbh mtdb) "drop trigger if exists update_tests_trigger") + (sqlite3:execute (dbr:dbdat-dbh mtdb) "drop trigger if exists update_runs_trigger")) + + ;; (print "mtdbmodtime " mtdbmodtime " tmpdbmodtime " tmpdbmodtime " mtdbpath " mtdbpath " " (conc *toppath* "/megatest.db")) + ;; (debug:print-info 13 *default-log-port* "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access) + (if (and dbexists (not write-access)) + (begin + (set! *db-write-access* #f) + (dbr:subdb-read-only-set! subdb #t))) + (dbr:subdb-mtdb-set! subdb mtdb) + (dbr:subdb-tmpdb-set! subdb tmpdb) + (dbr:subdb-dbstack-set! subdb (make-stack)) ;; BB: why a stack? Why would the number of db's be indeterminate? Is this a legacy of 1.db 2.db .. ? + (stack-push! (dbr:subdb-dbstack subdb) tmpdb) ;; olddb is already a (cons db path) + (dbr:subdb-refndb-set! subdb refndb) + (if (and (or (not dbfexists) + (and modtimedelta + (> modtimedelta max-stale-tmp))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back + do-sync) + (begin + (dbfile:print-err "filling db " (dbr:dbdat-dbfile tmpdb) " with data \n from " (dbr:dbdat-dbfile mtdb) " mod time delta: " modtimedelta) + (db:sync-tables (db:sync-all-tables-list subdb) #f mtdb refndb tmpdb) + ;; touch tmp db to avoid wal mode wierdness + (set! (file-modification-time tmpdbfname) (current-seconds)) + (dbfile:print-err "INFO: db:sync-all-tables-list done.") + ) + (dbfile:print-err " db, " (dbr:dbdat-dbfile tmpdb) " already exists or fresh enough, not propogating data from\n " (dbr:dbdat-dbfile mtdb) " mod time delta: " modtimedelta) ) + ;; (db:multi-db-sync subdb 'old2new)) ;; migrate data from megatest.db automatically + tmpdb)) + +;;====================================================================== +;; no-sync.db - small bits of data to be shared between servers +;;====================================================================== + +;; if we are not a server create a db handle. this is not finalized +;; so watch for problems. I'm still not clear if it is needed to manually +;; finalize sqlite3 dbs with the sqlite3 egg. +;; + +(define (dbfile:cautious-open-database fname init-proc #!optional (tries-left 10)) + (let* ((lock-file (conc fname".lock")) + (retry (lambda () + (thread-sleep! 1.1) + (if (> tries-left 0) + (dbfile:cautious-open-database fname init-proc (- tries-left 1)))))) + (assert (>= tries-left 0) (conc "FATAL: Five attempts in dbfile:cautious-open-database of "fname", giving up.")) + (if (and (file-write-access? fname) (not (dbfile:simple-file-lock lock-file))) + (begin + (dbfile:print-err "INFO: dbfile:cautious-open-database: lock file " lock-file " exists, trying again in 1 second.") + (thread-sleep! 1) + (if (eq? tries-left 2) + (begin + (dbfile:print-err "INFO: stealing the lock "lock-file) + (delete-file lock-file))) + (dbfile:cautious-open-database fname init-proc (- tries-left 1))) + (let* ((db-exists (file-exists? fname)) + (result (condition-case + (let* ((db (sqlite3:open-database fname))) + (if (and init-proc (not db-exists)) + (init-proc db)) + db) + (exn (io-error) + (dbfile:print-err exn "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.") + (retry)) + (exn (corrupt) + (dbfile:print-err exn "ERROR: database " fname " is corrupt. Repair it to proceed.") + (retry)) + (exn (busy) + (dbfile:print-err exn "ERROR: database " fname + " is locked. Try copying to another location, remove original and copy back.") + (retry)) + (exn (permission)(dbfile:print-err exn "ERROR: database " fname " has some permissions problem.") + (retry)) + (exn () + (dbfile:print-err exn "ERROR: Unknown error with database " fname " message: " + ((condition-property-accessor 'exn 'message) exn)) + (retry))))) + (if (file-write-access? fname) + (dbfile:simple-file-release-lock lock-file) + ) + result)))) + + +(define (dbfile:open-no-sync-db dbpath) + (if *no-sync-db* + *no-sync-db* + (begin + (if (not (file-exists? dbpath)) + (create-directory dbpath #t)) + (let* ((dbname (conc dbpath "/no-sync.db")) + (db-exists (file-exists? dbname)) + (init-proc (lambda (db) + (if (not db-exists) + (begin + (sqlite3:execute db "PRAGMA synchronous = 0;") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));")) + ))) + (db (dbfile:cautious-open-database dbname init-proc))) ;; (sqlite3:open-database dbname))) + (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) + ;;(sqlite3:execute db "PRAGMA journal_mode=WAL;") + (set! *no-sync-db* db) + db)))) + +(define (db:no-sync-set db var val) + (sqlite3:execute db "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES (?,?);" var val)) + +(define (db:no-sync-del! db var) + (sqlite3:execute db "DELETE FROM no_sync_metadat WHERE var=?;" var)) + +(define (db:no-sync-get/default db var default) + (let ((res default)) + (sqlite3:for-each-row + (lambda (val) + (set! res val)) + db + "SELECT val FROM no_sync_metadat WHERE var=?;" + var) + (if res + (let ((newres (if (string? res) + (string->number res) + #f))) + (if newres + newres + res)) + res))) + +;; transaction protected lock aquisition +;; either: +;; fails returns (#f . lock-creation-time) +;; succeeds (returns (#t . lock-creation-time) +;; use (db:no-sync-del! db keyname) to release the lock +;; +(define (db:no-sync-get-lock db keyname) + (sqlite3:with-transaction + db + (lambda () + (handle-exceptions + exn + (let ((lock-time (current-seconds))) + ;; (debug:print-info 2 *default-log-port* "db:no-sync-get-lock keyname=" keyname ", lock-time=" lock-time ", exn=" exn) + (sqlite3:execute db "INSERT INTO no_sync_metadat (var,val) VALUES(?,?);" keyname lock-time) + `(#t . ,lock-time)) + `(#f . ,(sqlite3:first-result db "SELECT val FROM no_sync_metadat WHERE var=?;" keyname)))))) + + +;;====================================================================== +;; file utils +;;====================================================================== + +;;====================================================================== +;; lazy-safe get file mod time. on any error (file not existing etc.) return 0 +;; +(define (dbfile:lazy-modification-time fpath) + (handle-exceptions + exn + (begin + (dbfile:print-err "Failed to get modification time for " fpath ", treating it as zero. exn=" exn) + 0) + (if (file-exists? fpath) + (file-modification-time fpath) + 0))) + +;;====================================================================== +;; find timestamp of newest file associated with a sqlite db file +(define (dbfile:lazy-sqlite-db-modification-time fpath) + (let* ((glob-list (handle-exceptions + exn + (begin + (dbfile:print-err "Failed to glob " fpath "*, exn=" exn) + `(,(conc "/no/such/file, message: " ((condition-property-accessor 'exn 'message) exn)))) + (glob (conc fpath "*")))) + (file-list (if (eq? 0 (length glob-list)) + '("/no/such/file") + glob-list))) + (apply max + (map + dbfile:lazy-modification-time + file-list)))) + +;; dot-locking egg seems not to work, using this for now +;; if lock is older than expire-time then remove it and try again +;; to get the lock +;; +(define (dbfile:simple-file-lock fname #!key (expire-time 300)) + (let ((fmod-time (handle-exceptions + ext + (current-seconds) + (file-modification-time fname)))) + (if (file-exists? fname) + (if (> (- (current-seconds) fmod-time) expire-time) + (begin + (handle-exceptions exn #f (delete-file* fname)) + (dbfile:simple-file-lock fname expire-time: expire-time)) + #f) + (let ((key-string (conc (get-host-name) "-" (current-process-id))) + (oup (open-output-file fname))) + (with-output-to-port + oup + (lambda () + (print key-string))) + (close-output-port oup) + #;(with-output-to-file fname ;; bizarre. with-output-to-file does not seem to be cleaning up after itself. + (lambda () + (print key-string))) + (thread-sleep! 0.25) + (if (file-exists? fname) + (handle-exceptions exn + #f + (with-input-from-file fname + (lambda () + (equal? key-string (read-line))))) + #f) + ) + ) + ) +) + +(define (dbfile:simple-file-lock-and-wait fname #!key (expire-time 300)) + (let ((end-time (+ expire-time (current-seconds)))) + (let loop ((got-lock (dbfile:simple-file-lock fname expire-time: expire-time))) + (if got-lock + #t + (if (> end-time (current-seconds)) + (begin + (thread-sleep! 3) + (loop (dbfile:simple-file-lock fname expire-time: expire-time))) + #f))))) + +(define (dbfile:simple-file-release-lock fname) + (handle-exceptions + exn + #f ;; I don't really care why this failed (at least for now) + (delete-file* fname))) + + +) ADDED debugprint.scm Index: debugprint.scm ================================================================== --- /dev/null +++ debugprint.scm @@ -0,0 +1,175 @@ + +(declare (unit debugprint)) +(declare (uses mtargs)) + +(module debugprint + * + +;;(import scheme chicken data-structures extras files ports) + (import + scheme + chicken + data-structures + posix + ports + extras + + ;; scheme + ;; chicken.base + ;; chicken.string + ;; chicken.time + ;; chicken.time.posix + ;; chicken.port + ;; chicken.process-context + ;; chicken.process-context.posix + + (prefix mtargs args:) + srfi-1 + ;; system-information + ) + +;;====================================================================== +;; debug stuff +;;====================================================================== + +(define verbosity (make-parameter '())) +(define *default-log-port* (current-error-port)) +(define debug:print-logger (make-parameter #f)) ;; set to a proc to call on every logging print + +(define (debug:setup) + (let ((debugstr (or (args:get-arg "-debug") + (args:get-arg "-debug-noprop") + (get-environment-variable "MT_DEBUG_MODE")))) + (verbosity (debug:calc-verbosity debugstr 'q)) + (debug:check-verbosity (verbosity) debugstr) + ;; if we were handed a bad verbosity rule then we will override it with 1 and continue + (if (not (verbosity))(verbosity 1)) + (if (and (not (args:get-arg "-debug-noprop")) + (or (args:get-arg "-debug") + (not (get-environment-variable "MT_DEBUG_MODE")))) + (setenv #;set-environment-variable! "MT_DEBUG_MODE" (if (list? (verbosity)) + (string-intersperse (map conc (verbosity)) ",") + (conc (verbosity))))))) + +;; check verbosity, #t is ok +(define (debug:check-verbosity verbosity vstr) + (if (not (or (number? verbosity) + (list? verbosity))) + (begin + (print "ERROR: Invalid debug value \"" vstr "\"") + #f) + #t)) + +;;====================================================================== +;; (define (debug:print . params) #f) +;; (define (debug:print-info . params) #f) +;; +;; (define (set-functions dbgp dbgpinfo) +;; (set! debug:print dbgp) +;; (set! debug:print-info dbgpinfo)) + +;;====================================================================== +;; this was cached based on results from profiling but it turned out the profiling +;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching +;; in for now but can probably take it out later. +;; +(define (debug:calc-verbosity vstr arg) ;; arg is 'v (verbose) or 'q (quiet) + (let* ((res (cond + ((number? vstr) vstr) + ((not (string? vstr)) 1) + ;; ((string-match "^\\s*$" vstr) 1) + (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ","))))) + (cond + ((> (length debugvals) 1) debugvals) + ((> (length debugvals) 0)(car debugvals)) + (else 1)))) + ((eq? arg 'v) 2) ;; verbose + ((eq? arg 'q) 0) ;; quiet + (else 1)))) + (verbosity res) + res)) + +;;====================================================================== +;; check verbosity, #t is ok +#;(define (debug-check-verbosity verbosity vstr) + (if (not (or (number? verbosity) + (list? verbosity))) + (begin + (print "ERROR: Invalid debug value \"" vstr "\"") + #f) + #t)) + +(define (debug:debug-mode n) + (let* ((vb (verbosity))) + (cond + ((and (number? vb) ;; number number + (number? n)) + (<= n vb)) + ((and (list? vb) ;; list number + (number? n)) + (member n vb)) + ((and (list? vb) ;; list list + (list? n)) + (not (null? (lset-intersection! eq? vb n)))) + ((and (number? vb) + (list? n)) + (member vb n)) + (else #f)))) + +(define (debug:handle-remote-logging params) + (if (debug:print-logger) ;; NOTE: turn params into string to keep things simple for now + ((debug:print-logger)(conc "REMOTE ("(get-host-name)", pid="(current-process-id)") " + (string-intersperse (map conc params) " ") "; " + (string-intersperse (command-line-arguments) " "))))) + +(define debug:enable-timestamp (make-parameter #t)) + +(define (debug:timestamp) + (if (debug:enable-timestamp) + (conc (time->string + (seconds->local-time (current-seconds)) "%H:%M:%S") " ") + "")) + + (define (debug:print n e . params) + (if (debug:debug-mode n) + (with-output-to-port (or e (current-error-port)) + (lambda () + ;; (if *logging* + ;; (db:log-event (apply conc params)) + (apply print (debug:timestamp) params) + ;; (debug:handle-remote-logging params) + ))) + #t ;; only here to make remote stuff happy. It'd be nice to fix that ... + ) + +(define (debug:print-error n e . params) + ;; normal print + (if (debug:debug-mode n) + (with-output-to-port (if (port? e) e (current-error-port)) + (lambda () + (apply print "ERROR: " (debug:timestamp) params) + ;; (debug:handle-remote-logging (cons "ERROR: " params)) + ))) + ;; pass important messages to stderr + (if (and (eq? n 0)(not (eq? e (current-error-port)))) + (with-output-to-port (current-error-port) + (lambda () + (apply print "ERROR: " (debug:timestamp) params) + )))) + +(define (debug:print-info n e . params) + (if (debug:debug-mode n) + (with-output-to-port (if (port? e) e (current-error-port)) + (lambda () + (apply print "INFO: (" n ") "(debug:timestamp) params) ;; res) + ;; (debug:handle-remote-logging (cons "INFO: " params)) + )))) + +(define (debug:print-warn n e . params) + (if (debug:debug-mode n) + (with-output-to-port (if (port? e) e (current-error-port)) + (lambda () + (apply print "WARN: (" n ") " (debug:timestamp) params) ;; res) + ;; (debug:handle-remote-logging (cons "WARN: " params)) + )))) +) DELETED filedb.scm Index: filedb.scm ================================================================== --- filedb.scm +++ /dev/null @@ -1,255 +0,0 @@ -;; Copyright 2006-2011, 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 . -;; - -;; (require-extension synch sqlite3 posix srfi-13 srfi-1 utils regex) -(use sqlite3 srfi-1 posix regex srfi-69 srfi-13 posix-extras) -(import (prefix sqlite3 sqlite3:)) - -(declare (unit filedb)) - -(include "fdb_records.scm") -;; (include "settings.scm") - -(define (filedb:open-db dbpath) - (let* ((fdb (make-filedb:fdb)) - (dbexists (common:file-exists? dbpath)) - (db (sqlite3:open-database dbpath))) - (filedb:fdb-set-db! fdb db) - (filedb:fdb-set-dbpath! fdb dbpath) - (filedb:fdb-set-pathcache! fdb (make-hash-table)) - (filedb:fdb-set-idcache! fdb (make-hash-table)) - (filedb:fdb-set-partcache! fdb (make-hash-table)) - (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) - (if (not dbexists) - (begin - (sqlite3:execute db "PRAGMA synchronous = OFF;") - (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id - (sqlite3:execute db "CREATE INDEX name_index ON names (name);") - ;; NB// We store a useful subset of file attributes but do not attempt to store all - (sqlite3:execute db "CREATE TABLE paths (id INTEGER PRIMARY KEY, - path TEXT, - parent_id INTEGER, - mode INTEGER DEFAULT -1, - uid INTEGER DEFAULT -1, - gid INTEGER DEFAULT -1, - size INTEGER DEFAULT -1, - mtime INTEGER DEFAULT -1);") - (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);") - (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT, updated TIMESTAMP);"))) - ;; close the sqlite3 db and open it as needed - (filedb:finalize-db! fdb) - (filedb:fdb-set-db! fdb #f) - fdb)) - -(define (filedb:reopen-db fdb) - (let ((db (sqlite3:open-database (filedb:fdb-get-dbpath fdb)))) - (filedb:fdb-set-db! fdb db) - (sqlite3:set-busy-handler! db (make-busy-timeout 136000)))) - -(define (filedb:finalize-db! fdb) - (sqlite3:finalize! (filedb:fdb-get-db fdb))) - -(define (filedb:get-current-time-string) - (string-chomp (time->string (seconds->local-time (current-seconds))))) - -(define (filedb:get-base-id db path) - (let ((stmt (sqlite3:prepare db "SELECT id FROM bases WHERE base=?;")) - (id-num #f)) - (sqlite3:for-each-row - (lambda (num) (set! id-num num)) stmt path) - (sqlite3:finalize! stmt) - id-num)) - -(define (filedb:get-path-id db path parent) - (let ((stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path=? AND parent_id=?;")) - (id-num #f)) - (sqlite3:for-each-row - (lambda (num) (set! id-num num)) stmt path parent) - (sqlite3:finalize! stmt) - id-num)) - -(define (filedb:add-base db path) - (let ((existing (filedb:get-base-id db path))) - (if existing #f - (begin - (sqlite3:execute db "INSERT INTO bases (base,updated) VALUES (?,?);" path (filedb:get-current-time-string)))))) - -;; index value field notes -;; 0 inode number st_ino -;; 1 mode st_mode bitfield combining file permissions and file type -;; 2 number of hard links st_nlink -;; 3 UID of owner st_uid as with file-owner -;; 4 GID of owner st_gid -;; 5 size st_size as with file-size -;; 6 access time st_atime as with file-access-time -;; 7 change time st_ctime as with file-change-time -;; 8 modification time st_mtime as with file-modification-time -;; 9 parent device ID st_dev ID of device on which this file resides -;; 10 device ID st_rdev device ID for special files (i.e. the raw major/minor number) -;; 11 block size st_blksize -;; 12 number of blocks allocated st_blocks - -(define (filedb:add-path-stat db path parent statinfo) - (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id,mode,uid,gid,size,mtime) VALUES (?,?,?,?,?,?,?);"))) - (sqlite3:execute stmt - path - parent - (vector-ref statinfo 1) ;; mode - (vector-ref statinfo 3) ;; uid - (vector-ref statinfo 4) ;; gid - (vector-ref statinfo 5) ;; size - (vector-ref statinfo 8) ;; mtime - ) - (sqlite3:finalize! stmt))) ;; (filedb:get-current-time-string)))) - -(define (filedb:add-path db path parent) - (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id) VALUES (?,?);"))) - (sqlite3:execute stmt path parent) - (sqlite3:finalize! stmt))) - -(define (filedb:register-path fdb path #!key (save-stat #f)) - (let* ((db (filedb:fdb-get-db fdb)) - (pathcache (filedb:fdb-get-pathcache fdb)) - (stat (if save-stat (file-stat path #t))) - (id (hash-table-ref/default pathcache path #f))) - (if (not db)(filedb:reopen-db fdb)) - (if id id - (let ((plist (string-split path "/"))) - (let loop ((head (car plist)) - (tail (cdr plist)) - (parent 0)) - (let ((id (filedb:get-path-id db head parent)) - (done (null? tail))) - (if id ;; we'll have a id if the path is already registered - (if done - (begin - (hash-table-set! pathcache path id) - id) ;; return the last path id for a result - (loop (car tail)(cdr tail) id)) - (begin ;; add the path and then repeat the loop with the same data - (if save-stat - (filedb:add-path-stat db head parent stat) - (filedb:add-path db head parent)) - (loop head tail parent))))))))) - -(define (filedb:update-recursively fdb path #!key (save-stat #f)) - (let ((p (open-input-pipe (string-append "find -L " path)))) ;; (resolve-pathname path)))) ;; (string-append "find " path)))) - (print "processed 0 files...") - (let loop ((l (read-line p)) - (lc 0)) ;; line count - (if (eof-object? l) - (begin - (print " " lc " files") - (close-input-port p)) - (begin - (filedb:register-path fdb l save-stat: save-stat) ;; (get-real-path l)) ;; don't like losing the original path info - (if (= (modulo lc 100) 0) - (print " " lc " files")) - (loop (read-line p)(+ lc 1))))))) - -(define (filedb:update fdb path #!key (save-stat #f)) - ;; first get the realpath and add it to the bases table - (let ((real-path path) ;; (filedb:get-real-path path)) - (db (filedb:fdb-get-db fdb))) - (filedb:add-base db real-path) - (filedb:update-recursively fdb path save-stat: save-stat))) - -;; not used and broken -;; -(define (filedb:get-real-path path) - (let* ((p (open-input-pipe (string-append real-path " " (regexp-escape path)))) - (pth (read-line p))) - (if (eof-object? pth) path - (begin - (close-input-port p) - pth)))) - -(define (filedb:drop-base fdb path) - (print "Sorry, I don't do anything yet")) - -(define (filedb:find-all fdb pattern action) - (let* ((db (filedb:fdb-get-db fdb)) - (stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path like ?;")) - (result '())) - (sqlite3:for-each-row - (lambda (num) - (action num) - (set! result (cons num result))) stmt pattern) - (sqlite3:finalize! stmt) - result)) - -(define (filedb:get-path-record fdb id) - (let* ((db (filedb:fdb-get-db fdb)) - (partcache (filedb:fdb-get-partcache fdb)) - (dat (hash-table-ref/default partcache id #f))) - (if dat dat - (let ((stmt (sqlite3:prepare db "SELECT path,parent_id FROM paths WHERE id=?;")) - (result #f)) - (sqlite3:for-each-row - (lambda (path parent_id)(set! result (list path parent_id))) stmt id) - (hash-table-set! partcache id result) - (sqlite3:finalize! stmt) - result)))) - -(define (filedb:get-children fdb parent-id) - (let* ((db (filedb:fdb-get-db fdb)) - (res '())) - (sqlite3:for-each-row - (lambda (id path parent-id) - (set! res (cons (vector id path parent-id) res))) - db "SELECT id,path,parent_id FROM paths WHERE parent_id=?;" - parent-id) - res)) - -;; retrieve all that have children and those without -;; children that match patt -(define (filedb:get-children-patt fdb parent-id search-patt) - (let* ((db (filedb:fdb-get-db fdb)) - (res '())) - ;; first get the children that have no children - (sqlite3:for-each-row - (lambda (id path parent-id) - (set! res (cons (vector id path parent-id) res))) - db "SELECT id,path,parent_id FROM paths WHERE parent_id=? AND - (id IN (SELECT parent_id FROM paths) OR path LIKE ?);" - parent-id search-patt) - res)) - -(define (filedb:get-path fdb id) - (let* ((db (filedb:fdb-get-db fdb)) - (idcache (filedb:fdb-get-idcache fdb)) - (path (hash-table-ref/default idcache id #f))) - (if (not db)(filedb:reopen-db fdb)) - (if path path - (let loop ((curr-id id) - (path "")) - (let ((path-record (filedb:get-path-record fdb curr-id))) - (if (not path-record) #f ;; this id has no path - (let* ((parent-id (list-ref path-record 1)) - (pname (list-ref path-record 0)) - (newpath (string-append "/" pname path))) - (if (= parent-id 0) ;; fields 0=path, 1=parent. root parent=0 - (begin - (hash-table-set! idcache id newpath) - newpath) - (loop parent-id newpath))))))))) - -(define (filedb:search db pattern) - (let ((action (lambda (id)(print (filedb:get-path db id))))) - (filedb:find-all db pattern action))) - DELETED fs-transport.scm Index: fs-transport.scm ================================================================== --- fs-transport.scm +++ /dev/null @@ -1,52 +0,0 @@ - -;; Copyright 2006-2012, 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 . - -(require-extension (srfi 18) extras tcp s11n) - -(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) -(import (prefix sqlite3 sqlite3:)) - -(use spiffy uri-common intarweb http-client spiffy-request-vars) - -(tcp-buffer-size 2048) - -(declare (unit fs-transport)) - -(declare (uses common)) -(declare (uses db)) -(declare (uses tests)) -(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. - -(include "common_records.scm") -(include "db_records.scm") - - -;;====================================================================== -;; F S T R A N S P O R T S E R V E R -;;====================================================================== - -;; There is no "server" per se but a convience routine to make it non -;; necessary to be reopening the db over and over again. -;; - -(define (fs:process-queue-item packet) - (if (not *dbstruct-db*) ;; we will require that (setup-for-run) has already been called - (set! *dbstruct-db* (db:setup-db))) - (debug:print-info 11 *default-log-port* "fs:process-queue-item called with packet=" packet) - (db:process-queue-item *dbstruct-db* packet)) - DELETED ftail.scm Index: ftail.scm ================================================================== --- ftail.scm +++ /dev/null @@ -1,108 +0,0 @@ -;;====================================================================== -;; 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 ftail)) - -(module ftail - ( - open-tail-db - tail-write - tail-get-fid - file-tail - ) - -(import scheme chicken data-structures extras) -(use (prefix sqlite3 sqlite3:) posix typed-records) - -(define (open-tail-db ) - (let* ((basedir (create-directory (conc "/tmp/" (current-user-name)))) - (dbpath (conc basedir "/megatest_logs.db")) - (dbexists (file-exists? dbpath)) - (db (sqlite3:open-database dbpath)) - (handler (sqlite3:make-busy-timeout 136000))) - (sqlite3:set-busy-handler! db handler) - (sqlite3:execute db "PRAGMA synchronous = 0;") - (if (not dbexists) - (begin - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_files (id INTEGER PRIMARY KEY,filename TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_data (id INTEGER PRIMARY KEY,fid INTEGER,line TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));") - )) - db)) - -(define (tail-write db fid lines) - (sqlite3:with-transaction - db - (lambda () - (for-each - (lambda (line) - (sqlite3:execute db "INSERT INTO log_data (fid,line) VALUES (?,?);" fid line)) - lines)))) - -(define (tail-get-fid db fname) - (let ((fid (handle-exceptions - exn - #f - (sqlite3:first-result db "SELECT id FROM log_files WHERE filename=?;" fname)))) - (if fid - fid - (begin - (sqlite3:execute db "INSERT INTO log_files (filename) VALUES (?);" fname) - (tail-get-fid db fname))))) - -(define (file-tail fname #!key (db-in #f)) - (let* ((inp (open-input-file fname)) - (db (or db-in (open-tail-db))) - (fid (tail-get-fid db fname))) - (let loop ((inl (read-line inp)) - (lines '()) - (lastwr (current-seconds))) - (if (eof-object? inl) - (let ((timed-out (> (- (current-seconds) lastwr) 60))) - (if timed-out (tail-write db fid (reverse lines))) - (sleep 1) - (if timed-out - (loop (read-line inp) '() (current-seconds)) - (loop (read-line inp) lines lastwr))) - (let* ((savelines (> (length lines) 19))) - ;; (print inl) - (if savelines (tail-write db fid (reverse lines))) - (loop (read-line inp) - (if savelines - '() - (cons inl lines)) - (if savelines - (current-seconds) - lastwr))))))) - -;; offset -20 means get last 20 lines -;; -(define (tail-get-lines db fid offset count) - (if (> offset 0) - (sqlite3:map-row (lambda (id line) - (vector id line)) - db - "SELECT id,line FROM log_data WHERE fid=? OFFSET ? LIMIT ?;" fid offset count) - (reverse ;; get N from the end - (sqlite3:map-row (lambda (id line) - (vector id line)) - db - "SELECT id,line FROM log_data WHERE fid=? ORDER BY id DESC LIMIT ?;" fid (abs offset))))) - -) DELETED sdb.scm Index: sdb.scm ================================================================== --- sdb.scm +++ /dev/null @@ -1,116 +0,0 @@ -;;====================================================================== -;; Copyright 2006-2013, 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 . - -;;====================================================================== - -;;====================================================================== -;; Simple persistant strings lookup table. Keep out of the main db -;; so writes/reads don't slow down central access. -;;====================================================================== - -(require-extension (srfi 18) extras) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) -(import (prefix sqlite3 sqlite3:)) -(import (prefix base64 base64:)) - -(declare (unit sdb)) - -;; -(define (sdb:open fname) - (let* ((dbpath (pathname-directory fname)) - (dbexists (let ((fe (common:file-exists? fname))) - (if fe - fe - (begin - (create-directory dbpath #t) - #f)))) - (sdb (sqlite3:open-database fname)) - (handler (make-busy-timeout 136000))) - (sqlite3:set-busy-handler! sdb handler) - (if (not dbexists) - (sdb:initialize sdb)) - (sqlite3:execute sdb "PRAGMA synchronous = 1;") - sdb)) - -(define (sdb:initialize sdb) - (sqlite3:execute sdb "CREATE TABLE IF NOT EXISTS strs - (id INTEGER PRIMARY KEY, - str TEXT, - CONSTRAINT str UNIQUE (str));") - (sqlite3:execute sdb "CREATE INDEX IF NOT EXISTS strindx ON strs (str);")) - -;; (define sumup (let ((a 0))(lambda (x)(set! a (+ x a)) a))) - -(define (sdb:register-string sdb str) - (sqlite3:execute sdb "INSERT OR IGNORE INTO strs (str) VALUES (?);" str)) - -(define (sdb:string->id sdb str-cache str) - (let ((id (hash-table-ref/default str-cache str #f))) - (if (not id) - (sqlite3:for-each-row - (lambda (sid) - (set! id sid) - (hash-table-set! str-cache str id)) - sdb - "SELECT id FROM strs WHERE str=?;" str)) - id)) - -(define (sdb:id->string sdb id-cache id) - (let ((str (hash-table-ref/default id-cache id #f))) - (if (not str) - (sqlite3:for-each-row - (lambda (istr) - (set! str istr) - (hash-table-set! id-cache id str)) - sdb - "SELECT str FROM strs WHERE id=?;" id)) - str)) - -;; Numbers get passed though in both directions -;; -(define (make-sdb:qry fname) - (let ((sdb #f) - (scache (make-hash-table)) - (icache (make-hash-table))) - (lambda (cmd var) - (case cmd - ((setup) (set! sdb (if (not sdb) - (sdb:open (if var var fname))))) - ((setdb) (set! sdb var)) - ((getdb) sdb) - ((finalize) (if sdb - (begin - (sqlite3:finalize! sdb) - (set! sdb #f)))) - ((getid) (let ((id (if (or (number? var) - (string->number var)) - var - (sdb:string->id sdb scache var)))) - (if id - id - (begin - (sdb:register-string sdb var) - (sdb:string->id sdb scache var))))) - ((getstr) (if (or (number? var) - (string->number var)) - (sdb:id->string sdb icache var) - var)) - ((passid) var) - ((passstr) var) - (else #f))))) - ADDED tests/simplerun/Makefile Index: tests/simplerun/Makefile ================================================================== --- /dev/null +++ tests/simplerun/Makefile @@ -0,0 +1,5 @@ + +cleanup : + killall mtest dboard -v -9 || true + rm -rf *.log *.bak NB* logs/* .meta .db /tmp/$(USER)/megatest_localdb/simplerun ../simpleruns/* lt + ADDED tests/simplerun/debug.scm Index: tests/simplerun/debug.scm ================================================================== --- /dev/null +++ tests/simplerun/debug.scm @@ -0,0 +1,61 @@ + +(module junk + * + +(import big-chicken + rmtmod + apimod + dbmod + srfi-18 + trace) + +(trace-call-sites #t) +(trace + ;; db:get-tests-for-run + ;; rmt:general-open-connection + ;; rmt:open-main-connection + ;; rmt:drop-conn + ;; rmt:send-receive + ;; rmt:log-to-main + ) + +(define (make-run-id) + (let* ((s (conc (current-process-id))) + (l (string-length s))) + (string->number (substring s (- l 3) l)) + )) + +(define (run) + (let* ((th1 (make-thread + (lambda () + (let loop ((r 0) + (i 1) + (s 0)) ;; sum + (let ((start-time (current-milliseconds)) + (run-id (+ r (make-run-id)))) + (rmt:register-test run-id "test1" (conc "item_" i)) + (thread-sleep! 0.01) + (let* ((qry-time (- (current-milliseconds) start-time)) + (tot-query-time (+ qry-time s)) + (avg-query-time (* 1.0 (/ tot-query-time (max i 1))))) + (if (> qry-time 500) + (print "WARNING: rmt:register-test took more than 500ms, "qry-time"ms, i="i", avg-query-time="avg-query-time)) + (if (eq? (modulo i 100) 0) + (print "For run-id="run-id", "(rmt:get-keys-write)" num tests registered="i" avg-query-time="avg-query-time)) + (if (< i 500) + (loop r (+ i 1) tot-query-time) + (if (< r 100) + (let* ((start-time (current-milliseconds))) + (print "rmt:get-keys "(rmt:get-keys)" in "(- (current-milliseconds) start-time)) + ;; run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode + (print "Got "(length (rmt:get-tests-for-run run-id "%" '() '() #f #f #f #f #f #f 0 #f))" tests for run "run-id) + (print "Average query time: "avg-query-time) + (loop (+ r 1) 0 tot-query-time)))))))) + ))) + (thread-start! th1) + (thread-join! th1))) + +(run) +) + + Index: tests/simplerun/megatest.config ================================================================== --- tests/simplerun/megatest.config +++ tests/simplerun/megatest.config @@ -20,10 +20,14 @@ RELEASE TEXT [setup] # Adjust max_concurrent_jobs to limit how much you load your machines max_concurrent_jobs 50 + +[server] +timeout 3 +# 3600 # Uncomment this to make the in-mem db into a disk based db (slower but good for debug) # be aware that some unit tests will fail with this due to persistent data # # tmpdb /tmp @@ -35,15 +39,15 @@ [validvalues] state start end completed # Job tools are more advanced ways to control how your jobs are launched [jobtools] -useshell yes -launcher nbfind +# useshell yes +launcher nbfake # You can override environment variables for all your tests here [env-override] EXAMPLE_VAR example value # As you run more tests you may need to add additional disks, the names are arbitrary but must be unique [disks] disk0 #{getenv MT_RUN_AREA_HOME}/../simpleruns Index: tests/simplerun/tests/test1/testconfig ================================================================== --- tests/simplerun/tests/test1/testconfig +++ tests/simplerun/tests/test1/testconfig @@ -24,11 +24,11 @@ [requirements] # waiton setup priority 0 # Iteration for your tests are controlled by the items section -[items] +# [items] # PARTOFDAY morning noon afternoon evening night # test_meta is a section for storing additional data on your test [test_meta] author matt ADDED tests/simplerun/thebeginning.scm Index: tests/simplerun/thebeginning.scm ================================================================== --- /dev/null +++ tests/simplerun/thebeginning.scm @@ -0,0 +1,126 @@ +(use trace test (prefix sqlite3 sqlite3:)) +(import dbfile) +(trace-call-sites #t) + +(trace + ;; dbfile:setup + ;; dbfile:open-sqlite3-db + ;; dbfile:init-subdb + ;; dbfile:add-dbdat + ;; db:initialize-main-db + ;; dbfile:set-subdb + ;; db:with-db + ;; dbfile:get-subdb + ) + +(system "touch /tmp/mmgraham/megatest_localdb/simplerun/.nfs.pdx.disks.icf_gwa_001.mmgraham.fossil.megatest1.7.mod.tests.simplerun/.db/10.db") + +;; *************** dbfile.scm tests **************** + + +;; (debug:print 0 *default-log-port* " tmp area: " (common:get-db-tmp-area)) + +(define tmpdir (common:get-db-tmp-area)) +(test #f #t (dbr:dbstruct? (dbfile:setup #t *toppath* tmpdir))) +(test #f #t (dbr:dbstruct? (db:setup #t))) +(define dbstruct *dbstruct-dbs*) +;; (test #f #t (dbr:subdb? (dbfile:init-subdb dbstruct #f db:initialize-main-db))) ;; this opens the nfs main db + +;; (test #f #t (dbr:dbdat? (dbfile:open-db *dbstruct-dbs* #f db:initialize-main-db))) ;; this opens the tmp db. +;; (define maindbdat (dbfile:open-db *dbstruct-dbs* #f db:initialize-main-db)) ;; this opens the tmp db. +;; (dbfile:add-dbdat dbstruct #f maindbdat) + +;;(test #f #t (dbr:subdb? (dbfile:get-subdb dbstruct #f))) +;; (test #f #t (dbr:dbdat? (dbfile:get-dbdat dbstruct #f))) +;; (test #f #f (dbr:dbdat? (dbfile:get-dbdat dbstruct #f))) ;; stack empty so should fail. + +;; (test #f #t (hash-table? (dbr:dbstruct-subdbs dbstruct))) +;; (test #f #t (stack? (dbr:subdb-dbstack (dbfile:get-subdb dbstruct #f)))) +;; (test #f '("SYSTEM" "RELEASE") (db:get-keys *dbstruct-dbs*)) + + +;; (test #f #t (dbr:dbdat? (dbfile:open-db dbstruct 1 db:initialize-main-db))) +;; (test #f #t (dbr:dbdat? (dbfile:open-db dbstruct 2 db:initialize-main-db))) +;; (define rundbdat (dbfile:open-db dbstruct 1 db:initialize-main-db)) +;; (define rundbdat2 (dbfile:open-db dbstruct 2 db:initialize-main-db)) +;; (define rundbdat3 (dbfile:open-db dbstruct 3 db:initialize-main-db)) +;; (dbfile:add-dbdat dbstruct 1 rundbdat) +;; (dbfile:add-dbdat dbstruct 2 rundbdat2) +;; (dbfile:add-dbdat dbstruct 3 rundbdat3) +;; (test #f #t (dbr:subdb? (dbfile:get-subdb dbstruct 1))) +;; (test #f #t (dbr:dbdat? (dbfile:get-dbdat dbstruct 1))) +;; (test #f #t (dbr:subdb? (dbfile:get-subdb dbstruct 2))) +;; (test #f #t (dbr:dbdat? (dbfile:get-dbdat dbstruct 2))) + + + +;; (test #f #t (> (dbfile:lazy-sqlite-db-modification-time ".db/main.db") 0)) +;; (test #f #t (> (dbfile:lazy-sqlite-db-modification-time ".db/1.db") 0)) +;; (test #f #t (> (dbfile:lazy-sqlite-db-modification-time ".db/2.db") 0)) + +;; (test #f #t (common:simple-file-lock "./db.lock")) +;; (test #f "./db.lock" (common:simple-file-release-lock "./db.lock")) + + + +;; *************** db.scm tests **************** + + +;; (define thisdbdat (db:open-db dbstruct #f)) +;; (test #f #t (dbr:dbdat? thisdbdat)) + +;; (test #f #t (dbr:dbdat? (db:get-db dbstruct #f))) +;; (test #f #t (dbr:dbdat? (db:get-db dbstruct 1))) +;; (test #f #t (dbr:dbdat? (db:get-db dbstruct 2))) + +;; (dbfile:add-dbdat dbstruct #f maindbdat) +;; (define maindbdat (dbfile:get-dbdat dbstruct #f)) +;; (dbfile:add-dbdat dbstruct #f maindbdat) + +;; (define mtdbdat2 (dbr:subdb-mtdbdat (dbfile:get-subdb dbstruct #f))) + +;; (define areapath (dbr:dbstruct-areapath dbstruct)) +;; (define mtdbpath (dbfile:run-id->path areapath #f)) +;; (define init-proc db:initialize-main-db) + +;; (define mtdbdat (dbfile:open-sqlite3-db mtdbpath init-proc)) + +;; (define maindb-handle (dbr:dbdat-dbh mtdbdat)) +;; (define maindb-handle2 (dbr:dbdat-dbh mtdbdat2)) + +;; (sqlite3:execute maindb-handle "vacuum") +;; (sqlite3:execute maindb-handle2 "vacuum") + +;; (define full-sel (conc "SELECT * from runs")) + +;; (sqlite3:for-each-row +;; (lambda (a . b) +;; (debug:print 0 *default-log-port* "a: " a " b: " b) +;; ) +;; maindb-handle +;; full-sel) + +;; (test #f #t (db:sync-touched dbstruct #f)) +;; (test #f #t (db:sync-touched dbstruct 1)) +;; (test #f #t (db:sync-touched dbstruct 2)) + +;; (test #f #t (dbr:subdb? (dbfile:get-subdb dbstruct #f))) +;; (test #f #t (dbr:subdb? (dbfile:get-subdb dbstruct (string->number "1")))) +;; (test #f #t (dbr:subdb? (dbfile:get-subdb dbstruct 2))) + + +;; (test #f #t (db:sync-touched dbstruct #f)) +;; (test #f #t (db:sync-touched dbstruct 1)) +;; (test #f #t (db:sync-touched dbstruct 2)) + + + +(test #f #t (db:all-db-sync dbstruct)) + +(exit) + +;; (test #f #t (db:close-all dbstruct)) +(test #f #t (db:safely-close-sqlite3-db (dbr:dbdat-dbh rundbdat) (dbr:dbdat-stmt-cache rundbdat))) +(test #f #t (db:safely-close-sqlite3-db (dbr:dbdat-dbh rundbdat2) (dbr:dbdat-stmt-cache rundbdat2))) +(test #f #t (db:safely-close-sqlite3-db (dbr:dbdat-dbh mtdbdat) (dbr:dbdat-stmt-cache mtdbdat))) +