ADDED   api.scm
Index: api.scm
==================================================================
--- /dev/null
+++ api.scm
@@ -0,0 +1,55 @@
+;;======================================================================
+;; Copyright 2006-2013, Matthew Welland.
+;; 
+;;  This program is made available under the GNU GPL version 2.0 or
+;;  greater. See the accompanying file COPYING for details.
+;; 
+;;  This program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;  PURPOSE.
+;;======================================================================
+
+(declare (unit api))
+(declare (uses rmt))
+(declare (uses db))
+
+;; These are called by the server on recipt of /api calls
+
+(define (api:execute-requests db cmd params)
+  (debug:print-info 1 "api:execute-requests cmd=" cmd " params=" params)
+  (db:process-cached-writes db)
+  (case (string->symbol cmd)
+    ;; KEYS
+    ((get-key-val-pairs)            (apply db:get-key-val-pairs db params))
+    ;; TESTS
+    ;; json doesn't do vectors, convert to list
+    ((get-test-info-by-id)	    (vector->list (apply db:get-test-info-by-id db params)))
+    ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id db params))
+    ((testmeta-get-record)          (vector->list (apply db:testmeta-get-record db params)))
+    ((test-set-state-status-by-id)  (apply db:test-set-state-status-by-id db params))
+    ;; RUNS
+    ((get-run-info)                 (let ((res (apply db:get-run-info db params)))
+				      (list (vector-ref res 0)
+					    (vector->list (vector-ref res 1)))))
+    (else
+     (list "ERROR" 0))))
+
+;; http-server  send-response
+;;                 api:process-request
+;;                    db:*
+;;
+;; NB// Runs on the server as part of the server loop
+;;
+(define (api:process-request db $) ;; the $ is the request vars proc
+  (let* ((cmd     ($ 'cmd))
+	 (paramsj ($ 'params))
+	 (params  (rmt:json-str->dat paramsj))
+	 (res     (api:execute-requests db cmd params)))
+    (rmt:dat->json-str
+     (if (or (string? res)
+	     (list?   res)
+	     (number? res)
+	     (boolean? res))
+	 res 
+	 (list "ERROR" 1 cmd params res)))))
+

ADDED   dbwars/NOTES
Index: dbwars/NOTES
==================================================================
--- /dev/null
+++ dbwars/NOTES
@@ -0,0 +1,31 @@
+Before using prepare:
+
+matt@xena:/tmp/megatest/dbwars$ ./sqlite3-test insert
+Adding 1047 test3 item/39 host0-0.3-200000-240-this one sucks eh? (added 51886 records so far)
+Adding 1122 test5 item/52 host2-0.2-200000-120-this is a good one eh? (added 78889 records so far)
+Adding 1050 test7 item/31 host1-0.1-100000-120-this is a good one eh? (added 110641 records so far)
+create-tests ran register-test 144000 times in 41.0 seconds
+
+After using prepare:
+
+matt@xena:/tmp/megatest/dbwars$ csc sqlite3-test.scm && ./sqlite3-test insert
+Adding 1082 test4 item/74 host1-0.3-100000-120-this is a good one eh? (added 61281 records so far)
+Adding 1138 test7 item/43 host2-0.3-200000-120-this is a good one eh? (added 109001 records so far)
+Adding 1023 test9 item/00 host0-0.2-100000-240-this one sucks eh? (added 143878 records so far)
+create-tests ran register-test 144000 times in 38.0 seconds
+
+After moving the prepare outside the call (so it isn't done each time):
+
+matt@xena:/tmp/megatest/dbwars$ ./sqlite3-test insert
+Adding 1042 test4 item/59 host0-0.3-200000-120-this is a good one eh? (added 63401 records so far)
+Adding 1011 test6 item/40 host0-0.1-200000-120-this one sucks eh? (added 94906 records so far)
+Adding 1076 test9 item/34 host1-0.2-200000-120-just eh, eh? (added 139035 records so far)
+create-tests ran register-test 144000 times in 33.0 seconds
+
+Using sql-de-lite with very similar code:
+
+matt@xena:/tmp/megatest/dbwars$ ./sql-de-lite-test insert
+Adding 1029 test4 item/53 host0-0.2-200000-240- (added 64252 records so far)
+Adding 1134 test7 item/64 host2-0.3-100000-240-this is a good one eh? (added 105973 records so far)
+create-tests ran register-test 144000 times in 31.0 seconds
+

ADDED   dbwars/sql-de-lite-test.scm
Index: dbwars/sql-de-lite-test.scm
==================================================================
--- /dev/null
+++ dbwars/sql-de-lite-test.scm
@@ -0,0 +1,19 @@
+
+(use sql-de-lite)
+(include "test-common.scm")
+
+(define db (open-database "test.db"))
+
+(exec (sql db test-table-defn))
+(exec (sql db syncsetup))
+
+(define (register-test stmth  run-id testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time)
+    (exec 
+     stmth ;; (sql db test-insert)
+     run-id
+     testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time))
+
+(let ((stmth (sql db test-insert)))
+  (create-tests stmth))
+
+(close-database db)

ADDED   dbwars/sqlite3-test.scm
Index: dbwars/sqlite3-test.scm
==================================================================
--- /dev/null
+++ dbwars/sqlite3-test.scm
@@ -0,0 +1,20 @@
+
+(use sqlite3)
+(include "test-common.scm")
+
+(define db (open-database "test.db"))
+
+(execute db test-table-defn)
+(execute db syncsetup)
+
+
+(define (register-test stmth run-id testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time)
+  (execute stmth
+	   run-id
+	   testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time))
+
+(let ((stmth (prepare db test-insert)))
+  (create-tests stmth)
+  (finalize! stmth))
+
+(finalize! db)

ADDED   dbwars/test-common.scm
Index: dbwars/test-common.scm
==================================================================
--- /dev/null
+++ dbwars/test-common.scm
@@ -0,0 +1,129 @@
+(use srfi-18 srfi-69 apropos)
+
+(define args (argv))
+
+(if (not (eq? (length args) 2))
+    (begin
+      (print "Usage: sqlitecompare [insert|update]")
+      (exit 0)))
+
+(define action (string->symbol (cadr args)))
+
+(system "rm -f test.db")
+
+(define test-table-defn
+		 "CREATE TABLE IF NOT EXISTS tests 
+                    (id INTEGER PRIMARY KEY,
+                     run_id     INTEGER,
+                     testname   TEXT,
+                     host       TEXT DEFAULT 'n/a',
+                     cpuload    REAL DEFAULT -1,
+                     diskfree   INTEGER DEFAULT -1,
+                     uname      TEXT DEFAULT 'n/a', 
+                     rundir     TEXT DEFAULT 'n/a',
+                     shortdir   TEXT DEFAULT '',
+                     item_path  TEXT DEFAULT '',
+                     state      TEXT DEFAULT 'NOT_STARTED',
+                     status     TEXT DEFAULT 'FAIL',
+                     attemptnum INTEGER DEFAULT 0,
+                     final_logf TEXT DEFAULT 'logs/final.log',
+                     logdat     BLOB, 
+                     run_duration INTEGER DEFAULT 0,
+                     comment    TEXT DEFAULT '',
+                     event_time TIMESTAMP,
+                     fail_count INTEGER DEFAULT 0,
+                     pass_count INTEGER DEFAULT 0,
+                     archived   INTEGER DEFAULT 0, -- 0=no, 1=in progress, 2=yes
+                     CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path)
+          );")
+
+(define test-insert "INSERT INTO tests  (run_id,testname,host,cpuload,diskfree,uname,rundir,shortdir,item_path,state,status,final_logf,run_duration,comment,event_time)
+                                values (?,     ?,       ?,   ?,      ?,       ?,    ?,     ?,       ?,        ?,    ?,     ?,         ?,           ?,      ?        );")
+(define syncsetup "PRAGMA synchronous = OFF;")
+
+(define tests '("test0" "test1" "test2" "test3" "test4" "test5" "test6" "test7" "test8" "test9"))
+(define items '())
+(for-each 
+ (lambda (n)
+   (for-each 
+    (lambda (m)
+      (set! items (cons (conc "item/" n m) items)))
+    '(0 1 2 3 4 5 6 7 8 9)))
+ '(0 1 2 3 4 5 6 7 8 9))
+(define hosts '("host0" "host1" "host2")) ;;  "host3" "host4" "host5" "host6" "host7" "host8" "host9"))
+(define cpuloads '(0.1 0.2 0.3))    ;; 0.4 0.5 0.6 0.7 0.8 0.9))
+(define diskfrees '(100000 200000)) ;; 300000 400000 500000 600000 700000 800000 900000))
+(define uname "Linux xena 3.5.0-40-generic #62~precise1-Ubuntu SMP Fri Aug 23 17:59:10 UTC 2013 i686 i686 i386 GNU/Linux")
+(define basedir "/mfs/matt/data/megatest/runs/testing")
+(define final-logf "finallog.html")
+(define run-durations (list 120 240)) ;;  260))
+(define comments '("" "this is a good one eh?" "this one sucks eh?" "just eh, eh?"))
+
+(define run-ids (make-hash-table))
+(define max-run-id 1000)
+
+(define (test-factors->run-id host cpuload diskfree run-duration comment)
+  (let* ((factor (conc host "-" cpuload "-" diskfree "-" run-duration "-" comment))
+	 (run-id (hash-table-ref/default run-ids factor #f)))
+    (if run-id 
+	(list run-id factor)
+	(let ((new-id (+ max-run-id 1)))
+	  (set! max-run-id new-id)
+	  (hash-table-set! run-ids factor new-id)
+	  (list new-id factor)))))
+	  
+
+(define (create-tests stmth)
+  (let ((num-created 0)
+	(last-print  (current-seconds))
+	(start-time  (current-seconds)))
+    (for-each 
+     (lambda (test)
+       (for-each 
+	(lambda (item)
+	  (for-each 
+	   (lambda (host)
+	     (for-each 
+	      (lambda (cpuload)
+		(for-each
+		 (lambda (diskfree)
+		   (for-each 
+		    (lambda (run-duration)
+		      (for-each 
+		       (lambda (comment)
+			 (let* ((run-id-dat (test-factors->run-id host cpuload diskfree run-duration comment))
+				(run-id (car run-id-dat))
+				(factor (cadr run-id-dat))
+				(curr-time (current-seconds)))
+			   (if (> (- curr-time last-print) 10)
+			       (begin
+				 (print "Adding " run-id " " test " " item " " factor " (added " num-created " records so far)")
+				 (set! last-print curr-time)))
+			   (set! num-created (+ num-created 1))
+			   (register-test stmth ;; db  
+					  run-id
+					  test  ;; testname
+					  host
+					  cpuload
+					  diskfree
+					  uname
+					  (conc basedir "/" test "/" item) ;; rundir
+					  (conc test "/" item) ;; shortdir
+					  item   ;; item-path
+					  "NOT_STARTED" ;; state
+					  "NA"          ;; status
+					  final-logf
+					  run-duration
+					  comment
+					  (current-seconds))))
+		       comments))
+		    run-durations))
+		 diskfrees))
+	      cpuloads))
+	   hosts))
+	items))
+     tests)
+    (print "create-tests ran register-test " num-created " times in " (- (current-seconds) start-time) " seconds")))
+
+				   
+			 

ADDED   rmt.scm
Index: rmt.scm
==================================================================
--- /dev/null
+++ rmt.scm
@@ -0,0 +1,134 @@
+;;======================================================================
+;; Copyright 2006-2013, Matthew Welland.
+;; 
+;;  This program is made available under the GNU GPL version 2.0 or
+;;  greater. See the accompanying file COPYING for details.
+;; 
+;;  This program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;  PURPOSE.
+;;======================================================================
+
+(use json)
+
+(declare (unit rmt))
+(declare (uses api))
+(declare (uses tdb))
+(declare (uses http-transport))
+
+;;
+;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!
+;;
+
+;;======================================================================
+;;  S U P P O R T   F U N C T I O N S
+;;======================================================================
+
+;; cmd is a symbol
+;; vars is a json string encoding the parameters for the call
+;;
+(define (rmt:send-receive cmd params)
+  (case *transport-type* 
+    ((fs)
+     (debug:print 0 "ERROR: Not yet (re)supported")
+     (exit 1))
+    ((http)
+     (let* ((jparams (rmt:dat->json-str params))
+	    (res (http-transport:client-api-send-receive *runremote* cmd jparams)))
+       (if res
+	   (rmt:json-str->dat res)
+	   (begin
+	     (debug:print 0 "ERROR: Bad value from http-transport:client-api-send-receive " res)
+	     #f))
+     ))
+    (else
+     (debug:print 0 "ERROR: Transport not yet (re)supported")
+     (exit 1))))
+
+;; Wrap json library for strings (why the ports crap in the first place?)
+(define (rmt:dat->json-str dat)
+  (with-output-to-string 
+    (lambda ()
+      (json-write dat))))
+
+(define (rmt:json-str->dat json-str)
+  (with-input-from-string json-str
+    (lambda ()
+      (json-read))))
+
+;;======================================================================
+;;
+;; A C T U A L   A P I   C A L L S  
+;;
+;;======================================================================
+
+;;======================================================================
+;;  K E Y S 
+;;======================================================================
+
+(define (rmt:get-key-val-pairs run-id)
+  (rmt:send-receive 'get-key-val-pairs (list run-id)))
+
+;;======================================================================
+;;  T E S T S
+;;======================================================================
+
+(define (rmt:get-test-info-by-id test-id)
+  (list->vector
+   (rmt:send-receive 'get-test-info-by-id (list test-id))))
+
+(define (rmt:test-get-rundir-from-test-id test-id)
+  (rmt:send-receive 'test-get-rundir-from-test-id (list test-id)))
+
+(define (rmt:open-test-db-by-test-id test-id #!key (work-area #f))
+  (let* ((test-path (if (string? work-area)
+			work-area
+			(rmt:test-get-rundir-from-test-id test-id))))
+    (debug:print 3 "TEST PATH: " test-path)
+    (open-test-db test-path)))
+
+(define (rmt:testmeta-get-record testname)
+  (list->vector
+   (rmt:send-receive 'testmeta-get-record (list testname))))
+
+;; WARNING: This currently bypasses the transaction wrapped writes system
+(define (rmt:test-set-state-status-by-id test-id newstate newstatus newcomment)
+  (rmt:send-receive 'test-set-state-status-by-id (list test-id newstate newstatus newcomment)))
+
+;;======================================================================
+;;  R U N S
+;;======================================================================
+
+(define (rmt:get-run-info run-id)
+  (let ((res (rmt:send-receive 'get-run-info (list run-id))))
+    (vector (car res)
+	    (list->vector (cadr res)))))
+
+;;======================================================================
+;;  S T E P S
+;;======================================================================
+
+;; Getting steps is more complicated.
+;;
+;; If given work area 
+;;  1. Find the testdat.db file
+;;  2. Open the testdat.db file and do the query
+;; If not given the work area
+;;  1. Do a remote call to get the test path
+;;  2. Continue as above
+;; 
+(define (rmt:get-steps-for-test test-id #!key (work-area #f))
+  (let* ((tdb (rmt:open-test-db-by-test-id test-id work-area: work-area)))
+    (if tdb
+	(tdb:get-steps-data tdb test-id)
+	'())))
+
+;;======================================================================
+;;  T E S T   D A T A 
+;;======================================================================
+
+(define (rmt:read-test-data test-id categorypatt #!key (work-area #f)) 
+  (let ((tdb  (rmt:open-test-db-by-test-id test-id work-area: work-area)))
+    (if tdb
+	(tdb:read-test-data tdb test-id categorypatt)
+	'())))

ADDED   rmtdb.scm
Index: rmtdb.scm
==================================================================
--- /dev/null
+++ rmtdb.scm
@@ -0,0 +1,11 @@
+;;======================================================================
+;; Copyright 2006-2013, Matthew Welland.
+;; 
+;;  This program is made available under the GNU GPL version 2.0 or
+;;  greater. See the accompanying file COPYING for details.
+;; 
+;;  This program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;  PURPOSE.
+;;======================================================================
+

ADDED   tdb.scm
Index: tdb.scm
==================================================================
--- /dev/null
+++ tdb.scm
@@ -0,0 +1,64 @@
+;;======================================================================
+;; Copyright 2006-2013, Matthew Welland.
+;; 
+;;  This program is made available under the GNU GPL version 2.0 or
+;;  greater. See the accompanying file COPYING for details.
+;; 
+;;  This program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;  PURPOSE.
+;;======================================================================
+
+;;======================================================================
+;; Database access
+;;======================================================================
+
+(require-extension (srfi 18) extras tcp) ;;  rpc)
+;; (import (prefix rpc rpc:))
+
+(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:))
+
+;; Note, try to remove this dependency 
+;; (use zmq)
+
+(declare (unit tdb))
+(declare (uses common))
+(declare (uses keys))
+(declare (uses ods))
+(declare (uses fs-transport))
+(declare (uses client))
+(declare (uses mt))
+
+(include "common_records.scm")
+(include "db_records.scm")
+(include "key_records.scm")
+(include "run_records.scm")
+
+;;======================================================================
+;;
+;; T E S T   D A T A B A S E S
+;;
+;;======================================================================
+
+(define (tdb:get-steps-data tdb test-id)
+  (let ((res '()))
+    (sqlite3:for-each-row 
+     (lambda (id test-id stepname state status event-time logfile)
+       (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res)))
+     tdb
+     "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
+     test-id)
+    (sqlite3:finalize! tdb)
+    (reverse res)))
+
+(define (tdb:read-test-data tdb test-id categorypatt)
+  (let ((res '()))
+    (sqlite3:for-each-row 
+     (lambda (id test_id category variable value expected tol units comment status type)
+       (set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
+     tdb
+     "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt)
+    (sqlite3:finalize! tdb)
+    (reverse res)))