Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -5,28 +5,31 @@ SRCFILES = common.scm items.scm launch.scm \ ods.scm runconfig.scm server.scm configf.scm \ db.scm keys.scm margs.scm megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ fs-transport.scm zmq-transport.scm http-transport.scm \ - client.scm + client.scm gutils.scm synchash.scm -GUISRCF = dashboard.scm dashboard-tests.scm dashboard-guimonitor.scm dashboard-main.scm +GUISRCF = dashboard-tests.scm dashboard-guimonitor.scm OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) ADTLSCR=mt_laststep mt_runstep mt_ezstep HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR)) DEPLOYHELPERS=$(addprefix $(DEPLOYTARG)/,$(ADTLSCR)) MTESTHASH=$(shell fossil info|grep checkout:| awk '{print $$2}') -all : mtest dboard +all : mtest dboard newdashboard mtest: $(OFILES) megatest.o csc $(CSCOPTS) $(OFILES) megatest.o -o mtest -dboard : $(OFILES) $(GOFILES) - csc $(OFILES) $(GOFILES) -o dboard +dboard : $(OFILES) $(GOFILES) dashboard.scm + csc $(OFILES) dashboard.scm $(GOFILES) -o dboard + +newdashboard : newdashboard.scm $(OFILES) + csc $(OFILES) newdashboard.scm -o newdashboard $(DEPLOYTARG)/megatest : $(OFILES) megatest.o csc -deployed $(CSCOPTS) $(OFILES) megatest.o -o $(DEPLOYTARG)/megatest $(DEPLOYTARG)/dashboard : $(OFILES) $(GOFILES) Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -29,11 +29,11 @@ (include "db_records.scm") ;; client:get-signature (define (client:get-signature) (if *my-client-signature* *my-client-signature* - (let ((sig (server:mk-signature))) + (let ((sig (conc (get-host-name) " " (current-process-id)))) (set! *my-client-signature* sig) *my-client-signature*))) ;; client:login serverdat (define (client:login serverdat) DELETED dashboard-main.scm Index: dashboard-main.scm ================================================================== --- dashboard-main.scm +++ /dev/null @@ -1,225 +0,0 @@ -;;====================================================================== -;; Copyright 2006-2012, 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. -;;====================================================================== - -;;====================================================================== -;; Main Megatest Panel -;;====================================================================== - -(use format) -(require-library iup) -(import (prefix iup iup:)) - -(use canvas-draw) - -(use sqlite3 srfi-1 posix regex regex-case srfi-69) -(import (prefix sqlite3 sqlite3:)) - -(declare (unit dashboard-main)) -(declare (uses common)) -(declare (uses keys)) -(declare (uses db)) -(declare (uses tasks)) - -(include "common_records.scm") -(include "db_records.scm") -(include "run_records.scm") -(include "task_records.scm") - -(define (main-menu) - (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top) - (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options - (iup:menu-item "Open" action: (lambda (obj) - (show (iup:file-dialog)) - (print "File->open " obj))) - (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj))) - (iup:menu-item "Exit" #:action (lambda (obj)(exit))))) - (iup:menu-item "Tools" (iup:menu - (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah"))) - ;; (iup:menu-item "Show dialog" #:action (lambda (obj) - ;; (show message-window - ;; #:modal? #t - ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current - ;; ;; #:x 'mouse - ;; ;; #:y 'mouse - ;; ) - )))) - - -(define (mtest) - (let* ((curr-row-num 0) - (rawconfig (read-config (conc *toppath* "/megatest.config") #f 'return-string)) - (keys-matrix (iup:matrix - #:expand "VERTICAL" - ;; #:scrollbar "YES" - #:numcol 1 - #:numlin 20 - #:numcol-visible 1 - #:numlin-visible 5 - #:click-cb (lambda (obj lin col status) - (print "obj: " obj " lin: " lin " col: " col " status: " status)))) - (setup-matrix (iup:matrix - #:expand "YES" - #:numcol 1 - #:numlin 5 - #:numcol-visible 1 - #:numlin-visible 3)) - (jobtools-matrix (iup:matrix - #:expand "YES" - #:numcol 1 - #:numlin 5 - #:numcol-visible 1 - #:numlin-visible 3)) - (validvals-matrix (iup:matrix - #:expand "YES" - #:numcol 1 - #:numlin 2 - #:numcol-visible 1 - #:numlin-visible 2)) - (envovrd-matrix (iup:matrix - #:expand "YES" - #:numcol 1 - #:numlin 20 - #:numcol-visible 1 - #:numlin-visible 8)) - (disks-matrix (iup:matrix - #:expand "YES" - #:numcol 1 - #:numlin 20 - #:numcol-visible 1 - #:numlin-visible 8))) - (iup:attribute-set! keys-matrix "0:0" "Field Num") - (iup:attribute-set! keys-matrix "0:1" "Field Name") - (iup:attribute-set! keys-matrix "WIDTH1" "100") - (iup:attribute-set! disks-matrix "0:0" "Disk Name") - (iup:attribute-set! disks-matrix "0:1" "Disk Path") - (iup:attribute-set! disks-matrix "WIDTH1" "120") - (iup:attribute-set! disks-matrix "WIDTH0" "100") - (iup:attribute-set! disks-matrix "ALIGNMENT1" "ALEFT") - (iup:attribute-set! disks-matrix "FIXTOTEXT" "C1") - (iup:attribute-set! disks-matrix "RESIZEMATRIX" "YES") - ;; fill in keys - (set! curr-row-num 1) - (for-each - (lambda (var) - (iup:attribute-set! keys-matrix (conc curr-row-num ":0") curr-row-num) - (iup:attribute-set! keys-matrix (conc curr-row-num ":1") var) - (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var))) - (configf:section-vars rawconfig "fields")) - - ;; fill in existing info - (for-each - (lambda (mat fname) - (set! curr-row-num 1) - (for-each - (lambda (var) - (iup:attribute-set! mat (conc curr-row-num ":0") var) - (iup:attribute-set! mat (conc curr-row-num ":1") (config-lookup rawconfig fname var)) - (set! curr-row-num (+ curr-row-num 1))) - (configf:section-vars rawconfig fname))) - (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix disks-matrix) - (list "setup" "jobtools" "validvalues" "env-override" "disks")) - - (for-each - (lambda (mat) - (iup:attribute-set! mat "0:1" "Value") - (iup:attribute-set! mat "0:0" "Var") - (iup:attribute-set! mat "ALIGNMENT1" "ALEFT") - (iup:attribute-set! mat "FIXTOTEXT" "C1") - (iup:attribute-set! mat "RESIZEMATRIX" "YES") - (iup:attribute-set! mat "WIDTH1" "120") - (iup:attribute-set! mat "WIDTH0" "100") - ) - (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix)) - - (iup:attribute-set! validvals-matrix "WIDTH1" "290") - (iup:attribute-set! envovrd-matrix "WIDTH1" "290") - - (iup:vbox - (iup:hbox - - (iup:vbox - (let ((tabs (iup:tabs - ;; The required tab - (iup:hbox - ;; The keys - (iup:frame - #:title "Keys (required)" - (iup:vbox - (iup:label (conc "Set the fields for organising your runs\n" - "here. Note: can only be changed before\n" - "running the first run when megatest.db\n" - "is created.")) - keys-matrix)) - (iup:vbox - ;; The setup section - (iup:frame - #:title "Setup" - (iup:vbox - (iup:label (conc "max_concurrent_jobs : limits total concurrent jobs (optional)\n" - "linktree : directory where linktree will be created.")) - setup-matrix)) - ;; The jobtools - (iup:frame - #:title "Jobtools" - (iup:vbox - (iup:label (conc "launcher : tool or script to run jobs (try nbfake)\n" - "useshell : use system to run your launcher\n" - "workhosts : spread jobs out on these hosts")) - jobtools-matrix)) - ;; The disks - (iup:frame - #:title "Disks" - (iup:vbox - (iup:label (conc "Enter names and existing paths of locations to run tests")) - disks-matrix)))) - ;; The optional tab - (iup:vbox - ;; The Environment Overrides - (iup:frame - #:title "Env override" - envovrd-matrix) - ;; The valid values - (iup:frame - #:title "Validvalues" - validvals-matrix) - )))) - (iup:attribute-set! tabs "TABTITLE0" "Required settings") - (iup:attribute-set! tabs "TABTITLE1" "Optional settings") - tabs)) - )))) - -(define (rconfig) - (iup:vbox - (iup:frame #:title "Default"))) - -(define (tests) - (iup:hbox - (iup:frame #:title "Tests browser"))) - -(define (runs) - (iup:hbox - (iup:frame #:title "Runs browser"))) - -(define (main-panel) - (iup:dialog - #:title "Menu Test" - #:menu (main-menu) - (let ((tabtop (iup:tabs - (runs) - (mtest) - (rconfig) - (tests) - ))) - (iup:attribute-set! tabtop "TABTITLE0" "Runs") - (iup:attribute-set! tabtop "TABTITLE3" "Tests") - (iup:attribute-set! tabtop "TABTITLE1" "megatest.config") - (iup:attribute-set! tabtop "TABTITLE2" "runconfigs.config") - tabtop))) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -27,11 +27,11 @@ (declare (uses process)) (declare (uses launch)) (declare (uses runs)) (declare (uses dashboard-tests)) (declare (uses dashboard-guimonitor)) -(declare (uses dashboard-main)) +;; (declare (uses dashboard-main)) (declare (uses megatest-version)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") @@ -99,10 +99,13 @@ ;; (define *keys* (db:get-keys *db*)) (define *dbkeys* (map (lambda (x)(vector-ref x 0)) (append *keys* (list (vector "runname" "blah"))))) (define *header* #f) (define *allruns* '()) +(define *allruns-by-id* (make-hash-table)) ;; +(define *runchangerate* (make-hash-table)) + (define *buttondat* (make-hash-table)) ;; (define *alltestnamelst* '()) (define *searchpatts* (make-hash-table)) (define *num-runs* 8) (define *tot-run-count* (cdb:remote-run db:get-num-runs #f "%")) @@ -162,15 +165,19 @@ (delta (map (lambda (a b)(abs (- a b))) c1 c2))) (null? (filter (lambda (x)(> x 3)) delta)))) ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) (define (update-rundat runnamepatt numruns testnamepatt keypatts) - (let ((modtime (file-modification-time *db-file-path*))) + (let ((modtime (file-modification-time *db-file-path*)) + (referenced-run-ids '())) (if (or (and (> modtime *last-db-update-time*) (> (current-seconds)(+ *last-db-update-time* 5))) (> *delayed-update* 0)) - (begin + ;; + ;; Run this stuff only when the megatest.db file has changed + ;; + (let ((full-run (> (random 100) 75))) ;; 25% of the time do a full refresh (debug:print-info 4 "update-rundat runnamepatt: " runnamepatt " numruns: " numruns " testnamepatt: " testnamepatt " keypatts: " keypatts) (set! *please-update-buttons* #t) (set! *last-db-update-time* modtime) (set! *delayed-update* (- *delayed-update* 1)) (let* ((allruns (cdb:remote-run db:get-runs #f runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) @@ -184,28 +191,50 @@ ;; (thread-sleep! 0.1) ;; give some time to other threads (debug:print 6 "update-rundat, got " (length runs) " runs") (if (> (+ *last-update* 300) (current-seconds)) ;; every five minutes (begin (set! *last-update* (current-seconds)) - (set! *tot-run-count* (length runs)))) ;; (rdb:get-num-runs *db* runnamepatt)))) + (set! *tot-run-count* (length runs)))) + ;; + ;; trim runs to only those that are changing often here + + ;; (for-each (lambda (run) (let* ((run-id (db:get-value-by-header run header "id")) (tests (let ((tsts (cdb:remote-run db:get-tests-for-run #f run-id testnamepatt states statuses))) (if *tests-sort-reverse* (reverse tsts) tsts))) (key-vals (cdb:remote-run db:get-key-vals #f run-id))) + ;; Not sure this is needed? + (set! referenced-run-ids (cons run-id referenced-run-ids)) (if (> (length tests) maxtests) (set! maxtests (length tests))) (if (or (not *hide-empty-runs*) ;; this reduces the data burden when set (not (null? tests))) - (set! result (cons (vector run tests key-vals) result))))) + (let ((dstruct (vector run tests key-vals))) + ;; + ;; compare the tests with the tests in *allruns-by-id* same run-id + ;; if different then increment value in *runchangerate* + ;; + (hash-table-set! *allruns-by-id* run-id dstruct) + (set! result (cons dstruct result)))))) runs) + + ;; + ;; if full-run use referenced-run-ids to delete data in *all-runs-by-id* and *runchangerate* + ;; + (set! *header* header) (set! *allruns* result) (debug:print 6 "*allruns* has " (length *allruns*) " runs") ;; (set! *tot-run-count* (+ 1 (length *allruns*))) maxtests)) - *num-tests*))) ;; FIXME, naughty coding eh? + ;; + ;; Run this if the megatest.db file did not get touched + ;; + (begin + + *num-tests*)))) ;; FIXME, naughty coding eh? (define *collapsed* (make-hash-table)) ; (define *row-lookup* (make-hash-table)) ;; testname => (rownum lableobj) (define (toggle-hide lnum) ; fulltestname) @@ -658,16 +687,14 @@ (begin (print "ERROR: testid is not a number " (args:get-arg "-test")) (exit 1))))) ((args:get-arg "-guimonitor") (gui-monitor *db*)) - ((args:get-arg "-main") - (iup:show (main-panel))) (else (set! uidat (make-dashboard-buttons *num-runs* *num-tests* *dbkeys*)) (iup:callback-set! *tim* "ACTION_CB" (lambda (x) (run-update x))))) ;(print x))))) (iup:main-loop) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -36,11 +36,11 @@ (include "run_records.scm") ;; timestamp type (val1 val2 ...) ;; type: meta-info, step (define *incoming-writes* '()) -(define *completed-writes* '()) +(define *completed-writes* (make-hash-table)) (define *incoming-last-time* (current-seconds)) (define *incoming-mutex* (make-mutex)) (define *completed-mutex* (make-mutex)) (define *cache-on* #f) @@ -504,10 +504,11 @@ ;;====================================================================== ;; R U N S ;;====================================================================== +;; keys list to key1,key2,key3 ... (define (runs:get-std-run-fields keys remfields) (let* ((header (append (map key:get-fieldname keys) remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) @@ -699,18 +700,18 @@ pth)) item-paths) (debug:print-info 11 "db:tests-register-test END db=" db ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") #f)) - ;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN ;; i.e. these lists define what to NOT show. ;; states and statuses are required to be lists, empty is ok ;; not-in #t = above behaviour, #f = must match (define (db:get-tests-for-run db run-id testpatt states statuses #!key (not-in #t) (sort-by #f) ;; 'rundir 'event_time + (qryvals "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment") ) (debug:print-info 11 "db:get-tests-for-run START run-id=" run-id ", testpatt=" testpatt ", states=" states ", statuses=" statuses ", not-in=" not-in ", sort-by=" sort-by) (let* ((res '()) ;; if states or statuses are null then assume match all when not-in is false (states-qry (if (null? states) @@ -726,11 +727,11 @@ (if not-in "NOT" "") " IN ('" (string-intersperse statuses "','") "')"))) (tests-match-qry (tests:match->sqlqry testpatt)) - (qry (conc "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment " + (qry (conc "SELECT " qryvals " FROM tests WHERE run_id=? " (if states-qry (conc " AND " states-qry) "") (if statuses-qry (conc " AND " statuses-qry) "") (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") (case sort-by @@ -746,10 +747,69 @@ qry run-id ) (debug:print-info 11 "db:get-tests-for-run START run-id=" run-id ", testpatt=" testpatt ", states=" states ", statuses=" statuses ", not-in=" not-in ", sort-by=" sort-by) res)) + +;; get a useful subset of the tests data (used in dashboard +;; use db:mintests-get-{id ,run_id,testname ...} +(define (db:get-tests-for-runs-mindata db run-ids testpatt states status) + (db:get-tests-for-runs db run-ids testpatt states status qryvals: "id,run_id,testname,state,status,event_time,item_path")) + +;; NB // This is get tests for "runs" (note the plural!!) +;; +;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN +;; i.e. these lists define what to NOT show. +;; states and statuses are required to be lists, empty is ok +;; not-in #t = above behaviour, #f = must match +;; run-ids is a list of run-ids or a single number +(define (db:get-tests-for-runs db run-ids testpatt states statuses + #!key (not-in #t) + (sort-by #f) + (qryvals "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")) ;; 'rundir 'event_time + (debug:print-info 11 "db:get-tests-for-run START run-ids=" run-ids ", testpatt=" testpatt ", states=" states ", statuses=" statuses ", not-in=" not-in ", sort-by=" sort-by) + (let* ((res '()) + ;; if states or statuses are null then assume match all when not-in is false + (states-qry (if (null? states) + #f + (conc " state " + (if not-in "NOT" "") + " IN ('" + (string-intersperse states "','") + "')"))) + (statuses-qry (if (null? statuses) + #f + (conc " status " + (if not-in "NOT" "") + " IN ('" + (string-intersperse statuses "','") + "')"))) + (tests-match-qry (tests:match->sqlqry testpatt)) + (qry (conc "SELECT " qryvals + " FROM tests WHERE " + (if run-ids + (if (list? run-ids) + (conc " run_id in (" (string-intersperse (map conc run-ids) ",") ") ") + (conc "run_id=" run-ids " ")) + " ") ;; #f => run-ids don't filter on run-ids + (if states-qry (conc " AND " states-qry) "") + (if statuses-qry (conc " AND " statuses-qry) "") + (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") + (case sort-by + ((rundir) " ORDER BY length(rundir) DESC;") + ((event_time) " ORDER BY event_time ASC;") + (else ";")) + ))) + (debug:print-info 8 "db:get-tests-for-run qry=" qry) + (sqlite3:for-each-row + (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) + (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) + db + qry + ) + (debug:print-info 11 "db:get-tests-for-run START run-ids=" run-ids ", testpatt=" testpatt ", states=" states ", statuses=" statuses ", not-in=" not-in ", sort-by=" sort-by) + res)) ;; this one is a bit broken BUG FIXME (define (db:delete-test-step-records db test-id) ;; Breaking it into two queries for better file access interleaving (let* ((tdb (db:open-test-db-by-test-id db test-id))) @@ -1038,21 +1098,10 @@ ;;====================================================================== ;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS ;;====================================================================== -;; db:updater is run in a thread to write out the cached data periodically -;; (define (db:updater) -;; (debug:print-info 4 "Starting cache processing") -;; (let loop () -;; (thread-sleep! 10) ;; move save time around to minimize regular collisions? -;; (db:write-cached-data) -;; (loop))) -;; The queue is a list of vectors where the zeroth slot indicates the type of query to -;; apply and the second slot is the time of the query and the third entry is a list of -;; values to be applied -;; ;; NOTE: Can remove the regex and base64 encoding for zmq (define (db:obj->string obj) (case *transport-type* ((fs) obj) ((http) @@ -1252,167 +1301,186 @@ killserver)) ;; not used, intended to indicate to run in calling process (define db:run-local-queries '()) ;; rollup-tests-pass-fail)) -(define (db:write-cached-data) - (open-run-close - (lambda (db . junkparams) - (let ((queries (make-hash-table)) - (data #f)) - (mutex-lock! *incoming-mutex*) - (set! data (reverse *incoming-writes*)) ;; (sort ... (lambda (a b)(< (vector-ref a 1)(vector-ref b 1))))) - (set! *incoming-writes* '()) - (mutex-unlock! *incoming-mutex*) - (if (> (length data) 0) - (debug:print-info 4 "Writing cached data " data)) - ;; prepare the needed statements - (for-each (lambda (request-item) - (let ((stmt-key (vector-ref request-item 0))) - (if (not (hash-table-ref/default queries stmt-key #f)) - (let ((stmt (alist-ref stmt-key db:queries))) - (if stmt - (hash-table-set! queries stmt-key (sqlite3:prepare db (car stmt))) - (debug:print 0 "ERROR: Missing query spec for " stmt-key "!")))))) - data) - ;; No outer loop needed. Single loop for write items only. Reads trigger flush of queue - ;; and then are executed. - (sqlite3:with-transaction - db - (lambda () - (debug:print-info 11 "flushing " data " to db") - (for-each - (lambda (hed) - (let ((params (vector-ref hed 2)) - (stmt-key (vector-ref hed 0))) - (debug:print-info 11 "Executing " stmt-key " for " params) - (apply sqlite3:execute (hash-table-ref queries stmt-key) params))) - data))) - ;; let all the waiting calls know all is done - (mutex-lock! *completed-mutex*) - (set! *completed-writes* (append *completed-writes* data)) - (mutex-unlock! *completed-mutex*) - ;; finalize the statements - (for-each (lambda (stmt-key) - (sqlite3:finalize! (hash-table-ref queries stmt-key))) - (hash-table-keys queries)) - ;; keep a little chest thumping data around - (let ((cache-size (length data))) - (if (> cache-size *max-cache-size*) - (set! *max-cache-size* cache-size))) - )) - #f)) - +(define (db:process-cached-writes db) + (let ((queries (make-hash-table)) + (data #f)) + (mutex-lock! *incoming-mutex*) + ;; data is a list of query packets (length data) 0) + ;; Process if we have data + (begin + (debug:print-info 7 "Writing cached data " data) + + ;; Prepare the needed sql statements + ;; + (for-each (lambda (request-item) + (let ((stmt-key (vector-ref request-item 0)) + (query (vector-ref request-item 1))) + (hash-table-set! queries stmt-key (sqlite3:prepare db query)))) + data) + + ;; No outer loop needed. Single loop for write items only. Reads trigger flush of queue + ;; and then are executed. + (sqlite3:with-transaction + db + (lambda () + (for-each + (lambda (hed) + (let* ((params (vector-ref hed 2)) + (stmt-key (vector-ref hed 0)) + (stmt (hash-table-ref/default queries stmt-key #f))) + (if stmt + (apply sqlite3:execute stmt params) + (debug:print 0 "ERROR: Problem Executing " stmt-key " for " params)))) + data))) + + ;; let all the waiting calls know all is done + (mutex-lock! *completed-mutex*) + (for-each (lambda (item) + (let ((qry-sig (cdb:packet-get-client-sig item))) + (debug:print-info 7 "Registering query " qry-sig " as done") + (hash-table-set! *completed-writes* qry-sig #t))) + data) + (mutex-unlock! *completed-mutex*) + + ;; Finalize the statements. Should this be done inside the mutex above? + ;; I think sqlite3 mutexes will keep the data safe + (for-each (lambda (stmt-key) + (sqlite3:finalize! (hash-table-ref queries stmt-key))) + (hash-table-keys queries)) + + ;; Do a little record keeping + (let ((cache-size (length data))) + (if (> cache-size *max-cache-size*) + (set! *max-cache-size* cache-size))) + #t) + #f))) + +(define *db:process-queue-mutex* (make-mutex)) + +(define *number-of-writes* 0) +(define *writes-total-delay* 0) +(define *total-non-write-delay* 0) +(define *number-non-write-queries* 0) ;; The queue is a list of vectors where the zeroth slot indicates the type of query to ;; apply and the second slot is the time of the query and the third entry is a list of ;; values to be applied ;; -;; (define (db:process-queue db pubsock indata) -;; (let* ((data (sort indata (lambda (a b) -;; (< (cdb:packet-get-qtime a)(cdb:packet-get-qtime b)))))) -;; (for-each -;; (lambda (item) -;; (db:process-queue-item db pubsock item)) -;; data))) - -(define (db:queue-write-and-wait db item) - (let ((res #f) - (got-it #f) - (qry-sig (cdb:packet-get-query-sig item))) +(define (db:queue-write-and-wait db qry-sig query params) + (let ((queue-len 0) + (res #f) + (got-it #f) + (qry-pkt (vector qry-sig query params)) + (start-time (current-milliseconds)) + (timeout (+ 10 (current-seconds)))) ;; set the time out to 10 secs in future + + ;; Put the item in the queue *incoming-writes* (mutex-lock! *incoming-mutex*) - (set! *incoming-writes (cons item *incoming-writes*)) + (set! *incoming-writes* (cons qry-pkt *incoming-writes*)) + (set! queue-len (length *incoming-writes*)) (mutex-unlock! *incoming-mutex*) - ;; let the queue build three times, look for processed - ;; item. - (let loop ((count 0)) - (debug:print-info 11 "db:queue-write-and-wait count=" count ", item=" item) + + (debug:print-info 7 "Current write queue length is " queue-len) + + ;; poll for the write to complete, timeout after 10 seconds + ;; periodic flushing of the queue is taken care of by + ;; db:flush-queue + (let loop () (thread-sleep! 0.1) (mutex-lock! *completed-mutex*) - (for-each (lambda (result) - (if (equal? (cdb:packet-get-query-sig result) qry-sig) - (set! got-it #t))) - *completed-writes*) - (mutex-unlock! *completed-mutex*) - (if (not got-it) - (if (< count 4) ;; give it 3/10 of a second of queue up time - (loop (+ count 1)) - (db:write-cached-data)))) - ;; at the point db:write-cached-data was called either by this call - ;; or by another. Now every 1/100 sec check to see if this query is - ;; at the "head" of the completed queue and pop it off - (let loop () - (thread-sleep! 0.001) - ;; there must always be at least one item in the completed-writes at this point, right? - (mutex-lock! *completed-mutex*) - (set! res (car *completed-writes*)) - (mutex-unlock! *completed-mutex*) - (if (equal? (cdb:packet-get-query-sig res) qry-sig) ;; yay! we are done! - (begin - (mutex-lock! *completed-mutex*) - (set! *completed-writes* (cdr *completed-writes*)) - (mutex-unlock! *completed-mutex*) - res) - (loop))))) + (if (hash-table-ref/default *completed-writes* qry-sig #f) + (begin + (hash-table-delete! *completed-writes* qry-sig) + (set! got-it #t))) + (mutex-unlock! *completed-mutex*) + (if (and (not got-it) + (< (current-seconds) timeout)) + (loop))) + (set! *number-of-writes* (+ *number-of-writes* 1)) + (set! *writes-total-delay* (+ *writes-total-delay* 1)) + got-it)) (define (db:process-queue-item db item) (let* ((stmt-key (cdb:packet-get-qtype item)) (qry-sig (cdb:packet-get-query-sig item)) (return-address (cdb:packet-get-client-sig item)) (params (cdb:packet-get-params item)) (query (let ((q (alist-ref stmt-key db:queries))) (if q (car q) #f)))) (debug:print-info 11 "Special queries/requests stmt-key=" stmt-key ", return-address=" return-address ", query=" query ", params=" params) - (cond - (query - ;; transactionize needed here. - ;; (case *transport-type* - ;; ((http)(db:queue-write-and-wait db item)) - ;; (else - (apply sqlite3:execute db query params) - ;; )) - (server:reply return-address qry-sig #t #t)) - ((member stmt-key db:special-queries) - (debug:print-info 11 "Handling special statement " stmt-key) - (case stmt-key - ((immediate) - (let ((proc (car params)) - (remparams (cdr params))) - ;; we are being handed a procedure so call it - (debug:print-info 11 "Running (apply " proc " " remparams ")") - (server:reply return-address qry-sig #t (apply proc remparams)))) - ((login) - (if (< (length params) 3) ;; should get toppath, version and signature - (server:reply return-address qry-sig '(#f "login failed due to missing params")) ;; missing params - (let ((calling-path (car params)) - (calling-vers (cadr params)) - (client-key (caddr params))) - (if (and (equal? calling-path *toppath*) - (equal? megatest-version calling-vers)) - (begin - (hash-table-set! *logged-in-clients* client-key (current-seconds)) - (server:reply return-address qry-sig #t '(#t "successful login"))) ;; path matches - pass! Should vet the caller at this time ... - (server:reply return-address qry-sig #f (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*))))))) - ((flush sync) - (server:reply return-address qry-sig #t 1)) ;; (length data))) - ((set-verbosity) - (set! *verbosity* (car params)) - (server:reply return-address qry-sig #t '(#t *verbosity*))) - ((killserver) - (debug:print 0 "WARNING: Server going down in 15 seconds by user request!") - (open-run-close tasks:server-deregister tasks:open-db - (car *runremote*) - pullport: (cadr *runremote*)) - (thread-start! (make-thread (lambda ()(thread-sleep! 15)(exit)))) - (server:reply return-address qry-sig #t '(#t "exit process started"))) - (else ;; not a command, i.e. is a query - (debug:print 0 "ERROR: Unrecognised query/command " stmt-key) - (server:reply pubsock return-address qry-sig #f 'failed)))) - (else - (debug:print-info 11 "Executing " stmt-key " for " params) - (apply sqlite3:execute (hash-table-ref queries stmt-key) params) - (server:reply return-address qry-sig #t #t))))) + (if query + ;; hand queries off to the write queue + (let ((response (case *transport-type* + ((http) + (debug:print-info 7 "Queuing item " item " for wrapped write") + (db:queue-write-and-wait db qry-sig query params)) + (else + (apply sqlite3:execute db query params) + #t)))) + (debug:print-info 7 "Received " response " from wrapped write") + (server:reply return-address qry-sig response response)) + ;; otherwise if appropriate flush the queue (this is a read or complex query) + (begin + (cond + ((member stmt-key db:special-queries) + (let ((starttime (current-milliseconds))) + (debug:print-info 11 "Handling special statement " stmt-key) + (case stmt-key + ((immediate) + ;; This is a read or mixed read-write query, must clear the cache + (case *transport-type* + ((http) + (mutex-lock! *db:process-queue-mutex*) + (db:process-cached-writes db) + (mutex-unlock! *db:process-queue-mutex*))) + (let* ((proc (car params)) + (remparams (cdr params)) + ;; we are being handed a procedure so call it + ;; (debug:print-info 11 "Running (apply " proc " " remparams ")") + (result (server:reply return-address qry-sig #t (apply proc remparams)))) + (set! *total-non-write-delay* (+ *total-non-write-delay* (- (current-milliseconds) starttime))) + (set! *number-non-write-queries* (+ *number-non-write-queries* 1)) + result)) + ((login) + (if (< (length params) 3) ;; should get toppath, version and signature + (server:reply return-address qry-sig '(#f "login failed due to missing params")) ;; missing params + (let ((calling-path (car params)) + (calling-vers (cadr params)) + (client-key (caddr params))) + (if (and (equal? calling-path *toppath*) + (equal? megatest-version calling-vers)) + (begin + (hash-table-set! *logged-in-clients* client-key (current-seconds)) + (server:reply return-address qry-sig #t '(#t "successful login"))) ;; path matches - pass! Should vet the caller at this time ... + (server:reply return-address qry-sig #f (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*))))))) + ((flush sync) + (server:reply return-address qry-sig #t 1)) ;; (length data))) + ((set-verbosity) + (set! *verbosity* (car params)) + (server:reply return-address qry-sig #t '(#t *verbosity*))) + ((killserver) + (debug:print 0 "WARNING: Server going down in 15 seconds by user request!") + (open-run-close tasks:server-deregister tasks:open-db + (car *runremote*) + pullport: (cadr *runremote*)) + (thread-start! (make-thread (lambda ()(thread-sleep! 15)(exit)))) + (server:reply return-address qry-sig #t '(#t "exit process started"))) + (else ;; not a command, i.e. is a query + (debug:print 0 "ERROR: Unrecognised query/command " stmt-key) + (server:reply return-address qry-sig #f 'failed))))) + (else + (debug:print-info 11 "Executing " stmt-key " for " params) + (apply sqlite3:execute (hash-table-ref queries stmt-key) params) + (server:reply return-address qry-sig #t #t))))))) (define (db:test-get-records-for-index-file db run-id test-name) (let ((res '())) (sqlite3:for-each-row (lambda (id itempath state status run_duration logf comment) Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -29,10 +29,21 @@ (define-inline (db:test-set-final_logf! vec val)(vector-set! vec 13 val)) ;; get rows and header from (define-inline (db:get-header vec)(vector-ref vec 0)) (define-inline (db:get-rows vec)(vector-ref vec 1)) + +;; make-vector-record "" db mintest id run_id testname state status event_time item_path +;; +(define (make-db:mintest)(make-vector 7)) +(define-inline (db:mintest-get-id vec) (vector-ref vec 0)) +(define-inline (db:mintest-get-run_id vec) (vector-ref vec 1)) +(define-inline (db:mintest-get-testname vec) (vector-ref vec 2)) +(define-inline (db:mintest-get-state vec) (vector-ref vec 3)) +(define-inline (db:mintest-get-status vec) (vector-ref vec 4)) +(define-inline (db:mintest-get-event_time vec) (vector-ref vec 5)) +(define-inline (db:mintest-get-item_path vec) (vector-ref vec 6)) ;; make-vector-record db testmeta id testname author owner description reviewed iterated avg_runtime avg_disk (define (make-db:testmeta)(make-vector 10 "")) (define-inline (db:testmeta-get-id vec) (vector-ref vec 0)) (define-inline (db:testmeta-get-testname vec) (vector-ref vec 1)) ADDED gutils.scm Index: gutils.scm ================================================================== --- /dev/null +++ gutils.scm @@ -0,0 +1,42 @@ +;;====================================================================== +;; Copyright 2006-2012, 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. +;;====================================================================== + +(require-library iup) +(import (prefix iup iup:)) +(use canvas-draw) + +(use srfi-1 regex regex-case srfi-69) +(declare (unit gutils)) + +(define (gutils:colors-similar? color1 color2) + (let* ((c1 (map string->number (string-split color1))) + (c2 (map string->number (string-split color2))) + (delta (map (lambda (a b)(abs (- a b))) c1 c2))) + (null? (filter (lambda (x)(> x 3)) delta)))) + +(define (gutils:get-color-for-state-status state status) + (case (string->symbol state) + ((COMPLETED) + (if (equal? status "PASS") + "70 249 73" + (if (or (equal? status "WARN") + (equal? status "WAIVED")) + "255 172 13" + "223 33 49"))) ;; greenish orangeish redish + ((LAUNCHED) "101 123 142") + ((CHECK) "255 100 50") + ((REMOTEHOSTSTART) "50 130 195") + ((RUNNING) "9 131 232") + ((KILLREQ) "39 82 206") + ((KILLED) "234 101 17") + ((NOT_STARTED) "240 240 240") + (else "192 192 192"))) + Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -59,13 +59,17 @@ (hostname (get-host-name)) (ipaddrstr (let ((ipstr (if (string=? "-" hostn) (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") #f))) (if ipstr ipstr hostn))) ;; hostname))) - (start-port (if (args:get-arg "-port") + (start-port (if (and (args:get-arg "-port") + (string->number (args:get-arg "-port"))) (string->number (args:get-arg "-port")) - (+ 5000 (random 1001)))) + (if (and (config-lookup *configdat* "server" "port") + (string->number (config-lookup *configdat* "server" "port"))) + (string->number (config-lookup *configdat* "server" "port")) + (+ 5000 (random 1001))))) (link-tree-path (config-lookup *configdat* "setup" "linktree"))) (set! *cache-on* #t) (root-path (if link-tree-path link-tree-path (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP! @@ -103,13 +107,11 @@ (send-response body: (conc "ctrl data\n" res "") headers: '((content-type text/plain))))) (else (continue)))))))) - (http-transport:try-start-server ipaddrstr start-port) - ;; lite3:finalize! db))) - )) + (http-transport:try-start-server ipaddrstr start-port))) ;; This is recursively run by http-transport:run until sucessful ;; (define (http-transport:try-start-server ipaddrstr portnum) (handle-exceptions @@ -132,17 +134,10 @@ (print "INFO: Trying to start server on " ipaddrstr ":" portnum) ;; This starts the spiffy server (start-server port: portnum) (print "INFO: server has been stopped"))) -(define (http-transport:mk-signature) - (message-digest-string (md5-primitive) - (with-output-to-string - (lambda () - (write (list (current-directory) - (argv))))))) - ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== ;;====================================================================== @@ -218,12 +213,18 @@ (loop)))))) (iface (car server-info)) (port (cadr server-info)) (last-access 0) (tdb (tasks:open-db)) - (spid (tasks:server-get-server-id tdb #f iface port #f))) - (print "Keep-running got server pid " spid ", using iface " iface " and port " port) + (spid (tasks:server-get-server-id tdb #f iface port #f)) + (server-timeout (let ((tmo (config-lookup *configdat* "server" "timeout"))) + (if (and (string? tmo) + (string->number tmo)) + (* 60 60 (string->number tmo)) + ;; default to three days + (* 3 24 60))))) + (debug:print-info 2 "server-timeout: " server-timeout ", server pid: " spid " on " iface ":" port) (let loop ((count 0)) (thread-sleep! 4) ;; no need to do this very often ;; NB// sync currently does NOT return queue-length (let () ;; (queue-len (cdb:client-call server-info 'sync #t 1))) ;; (print "Server running, count is " count) @@ -235,16 +236,12 @@ ;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access (mutex-lock! *heartbeat-mutex*) (set! last-access *last-db-access*) (mutex-unlock! *heartbeat-mutex*) - (if (> (+ last-access - ;; (* 50 60 60) ;; 48 hrs - ;; 60 ;; one minute - ;; (* 60 60) ;; one hour - (* 45 60) ;; 45 minutes, until the db deletion bug is fixed. - ) + ;; (debug:print 11 "last-access=" last-access ", server-timeout=" server-timeout) + (if (> (+ last-access server-timeout) (current-seconds)) (begin (debug:print-info 2 "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) (loop 0)) (begin @@ -251,11 +248,25 @@ (debug:print-info 0 "Starting to shutdown the server.") ;; need to delete only *my* server entry (future use) (set! *time-to-exit* #t) (tasks:server-deregister-self tdb (get-host-name)) (thread-sleep! 1) - (debug:print-info 0 "Max cached queries was " *max-cache-size*) + (debug:print-info 0 "Max cached queries was " *max-cache-size*) + (debug:print-info 0 "Number of cached writes " *number-of-writes*) + (debug:print-info 0 "Average cached write time " + (if (eq? *number-of-writes* 0) + "n/a (no writes)" + (/ *writes-total-delay* + *number-of-writes*)) + " ms") + (debug:print-info 0 "Number non-cached queries " *number-non-write-queries*) + (debug:print-info 0 "Average non-cached time " + (if (eq? *number-non-write-queries* 0) + "n/a (no queries)" + (/ *total-non-write-delay* + *number-non-write-queries*)) + " ms") (debug:print-info 0 "Server shutdown complete. Exiting") (exit))))))) ;; all routes though here end in exit ... (define (http-transport:launch) @@ -265,23 +276,42 @@ (debug:print 0 "ERROR: cannot find megatest.config, exiting") (exit)))) (debug:print-info 2 "Starting the standalone server") (let ((hostinfo (open-run-close tasks:get-best-server tasks:open-db))) (debug:print 11 "http-transport:launch hostinfo=" hostinfo) + ;; #(1 "143.182.207.24" 5736 -1 "http" 22771 "hostname") (if hostinfo - (debug:print-info 2 "NOT starting new server, one is already running on " (car hostinfo) ":" (cadr hostinfo)) + (debug:print-info 2 "NOT starting new server, one is already running on " (vector-ref hostinfo 1) ":" (vector-ref hostinfo 2)) (if *toppath* (let* ((th2 (make-thread (lambda () (http-transport:run (if (args:get-arg "-server") (args:get-arg "-server") "-"))) "Server run")) - (th3 (make-thread (lambda ()(http-transport:keep-running)) "Keep running")) - ) + (th3 (make-thread http-transport:keep-running "Keep running")) + (th1 (make-thread server:write-queue-handler "write queue"))) (thread-start! th2) (thread-start! th3) + (thread-start! th1) (set! *didsomething* #t) - (thread-join! th2) - ) + (thread-join! th2)) (debug:print 0 "ERROR: Failed to setup for megatest"))) (exit))) +(define (http-transport:server-signal-handler signum) + (handle-exceptions + exn + (debug:print " ... exiting ...") + (let ((th1 (make-thread (lambda () + (thread-sleep! 1)) + ;; (if (not *received-response*) + ;; (receive-message* *runremote*))) ;; flush out last call if applicable + "eat response")) + (th2 (make-thread (lambda () + (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") + (thread-sleep! 3) ;; give the flush three seconds to do it's stuff + (debug:print 0 " Done.") + (exit 4)) + "exit on ^C timer"))) + (thread-start! th2) + (thread-start! th1) + (thread-join! th2)))) ADDED iupexamples/iupwidgetinfo.scm Index: iupexamples/iupwidgetinfo.scm ================================================================== --- /dev/null +++ iupexamples/iupwidgetinfo.scm @@ -0,0 +1,191 @@ +#! /usr/bin/env csi + +(require-library srfi-4 iup) +(import srfi-4 iup iup-pplot iup-glcanvas) + +(define (popup dlg . args) + (apply show dlg #:modal? 'yes args) + (destroy! dlg)) + +(define (properties ih) + (popup (element-properties-dialog ih)) + 'default) + +(define dlg + (dialog + (vbox + (hbox ; headline + (fill) + (frame (label " Inspect control and dialog classes " + fontsize: 15)) + (fill) + margin: '0x0) + + (label "") + (label "Dialogs" fontsize: 12) + (hbox + (button "dialog" + action: (lambda (self) (properties (dialog (vbox))))) + (button "color-dialog" + action: (lambda (self) (properties (color-dialog)))) + (button "file-dialog" + action: (lambda (self) (properties (file-dialog)))) + (button "font-dialog" + action: (lambda (self) (properties (font-dialog)))) + (button "message-dialog" + action: (lambda (self) (properties (message-dialog)))) + (fill) + margin: '0x0) + (hbox + (button "layout-dialog" + action: (lambda (self) (properties (layout-dialog)))) + (button "element-properties-dialog" + action: (lambda (self) + (properties + (element-properties-dialog (create 'user))))) + (fill) + margin: '0x0) + + (label "") + (label "Composition widgets" fontsize: 12) + (hbox + (button "fill" + action: (lambda (self) (properties (fill)))) + (button "hbox" + action: (lambda (self) (properties (hbox)))) + (button "vbox" + action: (lambda (self) (properties (vbox)))) + (button "zbox" + action: (lambda (self) (properties (zbox)))) + (button "radio" + action: (lambda (self) (properties (radio (vbox))))) + (button "normalizer" + action: (lambda (self) (properties (normalizer)))) + (button "cbox" + action: (lambda (self) (properties (cbox)))) + (button "sbox" + action: (lambda (self) (properties (sbox (vbox))))) + (button "split" + action: (lambda (self) (properties (split (vbox) (vbox))))) + (fill) + margin: '0x0) + + (label "") + (label "Standard widgets" fontsize: 12) + (hbox + (button "button" + action: (lambda (self) (properties (button)))) + (button "canvas" + action: (lambda (self) (properties (canvas)))) + (button "frame" + action: (lambda (self) (properties (frame)))) + (button "label" + action: (lambda (self) (properties (label)))) + (button "listbox" + action: (lambda (self) (properties (listbox)))) + (button "progress-bar" + action: (lambda (self) (properties (progress-bar)))) + (button "spin" + action: (lambda (self) (properties (spin)))) + (fill) + margin: '0x0) + (hbox + (button "tabs" + action: (lambda (self) (properties (tabs)))) + (button "textbox" + action: (lambda (self) (properties (textbox)))) + (button "toggle" + action: (lambda (self) (properties (toggle)))) + (button "treebox" + action: (lambda (self) (properties (treebox)))) + (button "valuator" + action: (lambda (self) (properties (valuator "")))) + (fill) + margin: '0x0) + + (label "") + (label "Additional widgets" fontsize: 12) + (hbox + (button "cells" + action: (lambda (self) (properties (cells)))) + (button "color-bar" + action: (lambda (self) (properties (color-bar)))) + (button "color-browser" + action: (lambda (self) (properties (color-browser)))) + (button "dial" + action: (lambda (self) (properties (dial "")))) + (button "matrix" + action: (lambda (self) (properties (matrix)))) + (fill) + margin: '0x0) + (hbox + (button "pplot" + action: (lambda (self) (properties (pplot)))) + (button "glcanvas" + action: (lambda (self) (properties (glcanvas)))) + (button "web-browser" + action: (lambda (self) (properties (web-browser)))) + (fill) + margin: '0x0) + + (label "") + (label "Menu widgets" fontsize: 12) + (hbox + (button "menu" + action: (lambda (self) (properties (menu)))) + (button "menu-item" + action: (lambda (self) (properties (menu-item)))) + (button "menu-separator" + action: (lambda (self) (properties (menu-separator)))) + (fill) + margin: '0x0) + + (label "") + (label "Images" fontsize: 12) + (hbox + (button "image/palette" + action: (lambda (self) + (properties + (image/palette 1 1 (u8vector->blob (u8vector 0)))))) + (button "image/rgb" + action: (lambda (self) + (properties + (image/rgb 1 1 (u8vector->blob (u8vector 0)))))) + (button "image/rgba" + action: (lambda (self) + (properties + (image/rgba 1 1 (u8vector->blob (u8vector 0)))))) + (button "image/file" + action: (lambda (self) + (properties + ;; same attributes as image/palette + (image/palette 1 1 (u8vector->blob (u8vector 0)))))) + ;; needs a file in current directory + ;(image/file "chicken.ico")))) ; ok + ;(image/file "chicken.png")))) ; doesn't work + (fill) + margin: '0x0) + + (label "") + (label "Other widgets" fontsize: 12) + (hbox + (button "clipboard" + action: (lambda (self) (properties (clipboard)))) + (button "timer" + action: (lambda (self) (properties (timer)))) + (button "spinbox" + action: (lambda (self) (properties (spinbox (vbox))))) + (fill) + margin: '0x0) + + (fill) + (button "E&xit" + expand: 'horizontal + action: (lambda (self) 'close)) + ) + margin: '15x15 + title: "Iup inspector")) + +(show dlg) +(main-loop) +(exit 0) ADDED iupexamples/tree.scm Index: iupexamples/tree.scm ================================================================== --- /dev/null +++ iupexamples/tree.scm @@ -0,0 +1,28 @@ + +(use iup) + +(define t #f) + +(define tree-dialog + (dialog + #:title "Tree Test" + (let ((t1 (treebox + #:selection_cb (lambda (obj id state) + (print "selection_db with id=" id " state=" state) + (print "SPECIALDATA: " (attribute obj "SPECIALDATA")) + )))) + (set! t t1) + t1))) + +(show tree-dialog) +(map (lambda (elname el) + (print "Adding " elname " with value " el) + (attribute-set! t elname el) + (attribute-set! t "SPECIALDATA" el)) + '("VALUE" "NAME" "ADDLEAF" "ADDBRANCH1" "ADDLEAF2" "VALUE") + '("0" "Figures" "Other" "triangle" "equilateral" "4") + ) +(map (lambda (attr) + (print attr " is " (attribute t attr))) + '("KIND1" "PARENT2" "STATE1")) +(main-loop) ADDED newdashboard.scm Index: newdashboard.scm ================================================================== --- /dev/null +++ newdashboard.scm @@ -0,0 +1,505 @@ +;;====================================================================== +;; Copyright 2006-2012, 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 format) +(require-library iup) +(import (prefix iup iup:)) +(use canvas-draw) + +(use sqlite3 srfi-1 posix regex regex-case srfi-69) +(import (prefix sqlite3 sqlite3:)) + +(declare (uses margs)) +(declare (uses launch)) +(declare (uses megatest-version)) +(declare (uses gutils)) +(declare (uses db)) +(declare (uses server)) +(declare (uses synchash)) + +(include "common_records.scm") +(include "db_records.scm") +(include "key_records.scm") + +(define help (conc +"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest + version " megatest-version " + license GPL, Copyright (C) Matt Welland 2011 + +Usage: dashboard [options] + -h : this help + -server host:port : connect to host:port instead of db access + -test testid : control test identified by testid + -guimonitor : control panel for runs + +Misc + -rows N : set number of rows +")) + +;; process args +(define remargs (args:get-args + (argv) + (list "-rows" + "-run" + "-test" + "-debug" + "-host" + ) + (list "-h" + "-guimonitor" + "-main" + "-v" + "-q" + ) + args:arg-hash + 0)) + +(if (args:get-arg "-h") + (begin + (print help) + (exit))) + +(if (not (setup-for-run)) + (begin + (print "Failed to find megatest.config, exiting") + (exit 1))) + +(if (args:get-arg "-host") + (begin + (set! *runremote* (string-split (args:get-arg "-host" ":"))) + (client:launch)) + (client:launch)) + + +(debug:setup) + +(define *tim* (iup:timer)) +(define *ord* #f) +(iup:attribute-set! *tim* "TIME" 300) +(iup:attribute-set! *tim* "RUN" "YES") + +(define (message-window msg) + (iup:show + (iup:dialog + (iup:vbox + (iup:label msg #:margin "40x40"))))) + +(define (iuplistbox-fill-list lb items . default) + (let ((i 1) + (selected-item (if (null? default) #f (car default)))) + (iup:attribute-set! lb "VALUE" (if selected-item selected-item "")) + (for-each (lambda (item) + (iup:attribute-set! lb (number->string i) item) + (if selected-item + (if (equal? selected-item item) + (iup:attribute-set! lb "VALUE" item))) ;; (number->string i)))) + (set! i (+ i 1))) + items) + i)) + +(define (pad-list l n)(append l (make-list (- n (length l))))) + + +(define (mkstr . x) + (string-intersperse (map conc x) ",")) + +(define (update-search x val) + (hash-table-set! *searchpatts* x val)) + +(define (main-menu) + (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top) + (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options + (iup:menu-item "Open" action: (lambda (obj) + (iup:show (iup:file-dialog)) + (print "File->open " obj))) + (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj))) + (iup:menu-item "Exit" #:action (lambda (obj)(exit))))) + (iup:menu-item "Tools" (iup:menu + (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah"))) + ;; (iup:menu-item "Show dialog" #:action (lambda (obj) + ;; (show message-window + ;; #:modal? #t + ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current + ;; ;; #:x 'mouse + ;; ;; #:y 'mouse + ;; ) + )))) + + + +(define (mtest) + (let* ((curr-row-num 0) + (rawconfig (read-config (conc *toppath* "/megatest.config") #f 'return-string)) + (keys-matrix (iup:matrix + #:expand "VERTICAL" + ;; #:scrollbar "YES" + #:numcol 1 + #:numlin 20 + #:numcol-visible 1 + #:numlin-visible 5 + #:click-cb (lambda (obj lin col status) + (print "obj: " obj " lin: " lin " col: " col " status: " status)))) + (setup-matrix (iup:matrix + #:expand "YES" + #:numcol 1 + #:numlin 5 + #:numcol-visible 1 + #:numlin-visible 3)) + (jobtools-matrix (iup:matrix + #:expand "YES" + #:numcol 1 + #:numlin 5 + #:numcol-visible 1 + #:numlin-visible 3)) + (validvals-matrix (iup:matrix + #:expand "YES" + #:numcol 1 + #:numlin 2 + #:numcol-visible 1 + #:numlin-visible 2)) + (envovrd-matrix (iup:matrix + #:expand "YES" + #:numcol 1 + #:numlin 20 + #:numcol-visible 1 + #:numlin-visible 8)) + (disks-matrix (iup:matrix + #:expand "YES" + #:numcol 1 + #:numlin 20 + #:numcol-visible 1 + #:numlin-visible 8)) + ) + (iup:attribute-set! keys-matrix "0:0" "Field Num") + (iup:attribute-set! keys-matrix "0:1" "Field Name") + (iup:attribute-set! keys-matrix "WIDTH1" "100") + (iup:attribute-set! disks-matrix "0:0" "Disk Name") + (iup:attribute-set! disks-matrix "0:1" "Disk Path") + (iup:attribute-set! disks-matrix "WIDTH1" "120") + (iup:attribute-set! disks-matrix "WIDTH0" "100") + (iup:attribute-set! disks-matrix "ALIGNMENT1" "ALEFT") + (iup:attribute-set! disks-matrix "FIXTOTEXT" "C1") + (iup:attribute-set! disks-matrix "RESIZEMATRIX" "YES") + ;; fill in keys + (set! curr-row-num 1) + (for-each + (lambda (var) + (iup:attribute-set! keys-matrix (conc curr-row-num ":0") curr-row-num) + (iup:attribute-set! keys-matrix (conc curr-row-num ":1") var) + (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var))) + (configf:section-vars rawconfig "fields")) + + ;; fill in existing info + (for-each + (lambda (mat fname) + (set! curr-row-num 1) + (for-each + (lambda (var) + (iup:attribute-set! mat (conc curr-row-num ":0") var) + (iup:attribute-set! mat (conc curr-row-num ":1") (config-lookup rawconfig fname var)) + (set! curr-row-num (+ curr-row-num 1))) + (configf:section-vars rawconfig fname))) + (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix disks-matrix) + (list "setup" "jobtools" "validvalues" "env-override" "disks")) + + (for-each + (lambda (mat) + (iup:attribute-set! mat "0:1" "Value") + (iup:attribute-set! mat "0:0" "Var") + (iup:attribute-set! mat "ALIGNMENT1" "ALEFT") + (iup:attribute-set! mat "FIXTOTEXT" "C1") + (iup:attribute-set! mat "RESIZEMATRIX" "YES") + (iup:attribute-set! mat "WIDTH1" "120") + (iup:attribute-set! mat "WIDTH0" "100") + ) + (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix)) + + (iup:attribute-set! validvals-matrix "WIDTH1" "290") + (iup:attribute-set! envovrd-matrix "WIDTH1" "290") + + (iup:vbox + (iup:hbox + + (iup:vbox + (let ((tabs (iup:tabs + ;; The required tab + (iup:hbox + ;; The keys + (iup:frame + #:title "Keys (required)" + (iup:vbox + (iup:label (conc "Set the fields for organising your runs\n" + "here. Note: can only be changed before\n" + "running the first run when megatest.db\n" + "is created.")) + keys-matrix)) + (iup:vbox + ;; The setup section + (iup:frame + #:title "Setup" + (iup:vbox + (iup:label (conc "max_concurrent_jobs : limits total concurrent jobs (optional)\n" + "linktree : directory where linktree will be created.")) + setup-matrix)) + ;; The jobtools + (iup:frame + #:title "Jobtools" + (iup:vbox + (iup:label (conc "launcher : tool or script to run jobs (try nbfake)\n" + "useshell : use system to run your launcher\n" + "workhosts : spread jobs out on these hosts")) + jobtools-matrix)) + ;; The disks + (iup:frame + #:title "Disks" + (iup:vbox + (iup:label (conc "Enter names and existing paths of locations to run tests")) + disks-matrix)))) + ;; The optional tab + (iup:vbox + ;; The Environment Overrides + (iup:frame + #:title "Env override" + envovrd-matrix) + ;; The valid values + (iup:frame + #:title "Validvalues" + validvals-matrix) + )))) + (iup:attribute-set! tabs "TABTITLE0" "Required settings") + (iup:attribute-set! tabs "TABTITLE1" "Optional settings") + tabs)) + )))) + +(define (rconfig) + (iup:vbox + (iup:frame #:title "Default"))) + +(define (tests) + (iup:hbox + (iup:frame #:title "Tests browser"))) + +(define *runs-matrix* #f) + +(define (runs) + (let* ((runs-matrix (iup:matrix + #:expand "YES" + ;; #:fittosize "YES" + #:scrollbar "YES" + #:numcol 100 + #:numlin 100 + #:numcol-visible 7 + #:numlin-visible 7 + #:click-cb (lambda (obj lin col status) + (print "obj: " obj " lin: " lin " col: " col " status: " status))))) +;; (iup:attribute-set! keys-matrix "0:0" "Field Num") +;; (iup:attribute-set! keys-matrix "0:1" "Field Name") +;; (iup:attribute-set! keys-matrix "WIDTH1" "100") +;; (iup:attribute-set! disks-matrix "0:0" "Disk Name") +;; (iup:attribute-set! disks-matrix "0:1" "Disk Path") +;; (iup:attribute-set! disks-matrix "WIDTH1" "120") +;; (iup:attribute-set! disks-matrix "WIDTH0" "100") +;; (iup:attribute-set! disks-matrix "ALIGNMENT1" "ALEFT") +;; (iup:attribute-set! disks-matrix "FIXTOTEXT" "C1") +;; (iup:attribute-set! disks-matrix "RESIZEMATRIX" "YES") + ;; fill in keys +;; (set! curr-row-num 1) +;; (for-each +;; (lambda (var) +;; (iup:attribute-set! keys-matrix (conc curr-row-num ":0") curr-row-num) +;; (iup:attribute-set! keys-matrix (conc curr-row-num ":1") var) +;; (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var))) +;; (configf:section-vars rawconfig "fields")) + + ;; fill in existing info +;; (for-each +;; (lambda (mat fname) +;; (set! curr-row-num 1) +;; (for-each +;; (lambda (var) +;; (iup:attribute-set! mat (conc curr-row-num ":0") var) +;; (iup:attribute-set! mat (conc curr-row-num ":1") (config-lookup rawconfig fname var)) +;; (set! curr-row-num (+ curr-row-num 1))) +;; (configf:section-vars rawconfig fname))) +;; (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix disks-matrix) +;; (list "setup" "jobtools" "validvalues" "env-override" "disks")) + + (iup:attribute-set! runs-matrix "RESIZEMATRIX" "YES") + (iup:attribute-set! runs-matrix "WIDTH0" "100") + +;; (iup:attribute-set! validvals-matrix "WIDTH1" "290") +;; (iup:attribute-set! envovrd-matrix "WIDTH1" "290") + (set! *runs-matrix* runs-matrix) + (iup:hbox + (iup:frame + #:title "Runs browser" + (iup:vbox + runs-matrix))))) + +(define (main-panel) + (iup:dialog + #:title "Menu Test" + #:menu (main-menu) + (let ((tabtop (iup:tabs + (runs) + (mtest) + (rconfig) + (tests) + ))) + (iup:attribute-set! tabtop "TABTITLE0" "Runs") + (iup:attribute-set! tabtop "TABTITLE3" "Tests") + (iup:attribute-set! tabtop "TABTITLE1" "megatest.config") + (iup:attribute-set! tabtop "TABTITLE2" "runconfigs.config") + tabtop))) + +;;====================================================================== +;; Process runs +;;====================================================================== + +(define *data* (make-hash-table)) +(hash-table-set! *data* "runid-to-col" (make-hash-table)) +(hash-table-set! *data* "testname-to-row" (make-hash-table)) + +;; TO-DO +;; 1. Make "data" hash-table hierarchial store of all displayed data +;; 2. Update synchash to understand "get-runs", "get-tests" etc. +;; 3. Add extraction of filters to synchash calls +;; +;; Mode is 'full or 'incremental for full refresh or incremental refresh +(define (run-update keys data runname keypatts testpatt states statuses mode) + (let* (;; count and offset => #f so not used + ;; the synchash calls modify the "data" hash + (get-runs-sig (conc (client:get-signature) " get-runs")) + (get-tests-sig (conc (client:get-signature) " get-tests")) + (run-changes (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data runname #f #f keypatts)) + ;; Now can calculate the run-ids + (run-hash (hash-table-ref/default data get-runs-sig #f)) + (run-ids (if run-hash (filter number? (hash-table-keys run-hash)) '())) + (test-changes (synchash:client-get 'db:get-tests-for-runs-mindata get-tests-sig 0 data run-ids testpatt states statuses)) + (runs-hash (hash-table-ref/default data get-runs-sig #f)) + (header (hash-table-ref/default runs-hash "header" #f)) + (run-ids (sort (filter number? (hash-table-keys runs-hash)) + (lambda (a b) + (let* ((record-a (hash-table-ref runs-hash a)) + (record-b (hash-table-ref runs-hash b)) + (time-a (db:get-value-by-header record-a header "event_time")) + (time-b (db:get-value-by-header record-b header "event_time"))) + (> time-a time-b))) + )) + (runid-to-col (hash-table-ref *data* "runid-to-col")) + (testname-to-row (hash-table-ref *data* "testname-to-row")) + (colnum 1) + (rownum 0)) ;; rownum = 0 is the header + ;; tests related stuff + ;; (all-testnames (delete-duplicates (map db:test-get-testname test-changes)))) + + ;; Given a run-id and testname/item_path calculate a cell R:C + + + ;; Each run is unique on its keys and runname or run-id, store in hash on colnum + (for-each (lambda (run-id) + (let* (;; (run-id (db:get-value-by-header rundat header "id")) + (run-record (hash-table-ref/default runs-hash run-id #f)) + (key-vals (map (lambda (key)(db:get-value-by-header run-record header key)) + (map key:get-fieldname keys))) + (run-name (db:get-value-by-header run-record header "runname")) + (col-name (conc (string-intersperse key-vals "\n") "\n" run-name))) + (iup:attribute-set! *runs-matrix* (conc rownum ":" colnum) col-name) + (hash-table-set! runid-to-col run-id (list colnum run-record)) + (set! colnum (+ colnum 1)))) + run-ids) + + ;; Scan all tests to be displayed and organise all the test names, respecting what is in the hash table + ;; Do this analysis in the order of the run-ids, the most recent run wins + (for-each (lambda (run-id) + (let* ((new-test-dat (car test-changes)) + (removed-tests (cadr test-changes)) + (tests (sort (map cadr (filter (lambda (testrec) + (eq? run-id (db:mintest-get-run_id (cadr testrec)))) + new-test-dat)) + (lambda (a b) + (let ((time-a (db:mintest-get-event_time a)) + (time-b (db:mintest-get-event_time b))) + (> time-a time-b))))) + ;; test-changes is a list of (( id record ) ... ) + ;; Get list of test names sorted by time, remove tests + (test-names (delete-duplicates (map (lambda (t) + (let ((i (db:mintest-get-item_path t)) + (n (db:mintest-get-testname t))) + (if (string=? i "") + (conc " " i) + n))) + tests))) + (colnum (car (hash-table-ref runid-to-col run-id)))) + ;; for each test name get the slot if it exists and fill in the cell + ;; or take the next slot and fill in the cell, deal with items in the + ;; run view panel? The run view panel can have a tree selector for + ;; browsing the tests/items + + ;; SWITCH THIS TO USING CHANGED TESTS ONLY + (for-each (lambda (test) + (let* ((state (db:mintest-get-state test)) + (status (db:mintest-get-status test)) + (testname (db:mintest-get-testname test)) + (itempath (db:mintest-get-item_path test)) + (fullname (conc testname "/" itempath)) + (dispname (if (string=? itempath "") testname (conc " " itempath))) + (rownum (hash-table-ref/default testname-to-row fullname #f))) + (if (not rownum) + (let ((rownums (hash-table-values testname-to-row))) + (set! rownum (if (null? rownums) + 1 + (+ 1 (apply max rownums)))) + (hash-table-set! testname-to-row fullname rownum) + ;; create the label + (iup:attribute-set! *runs-matrix* (conc rownum ":" 0) dispname) + )) + ;; set the cell text and color + ;; (debug:print 2 "rownum:colnum=" rownum ":" colnum ", state=" status) + (iup:attribute-set! *runs-matrix* (conc rownum ":" colnum) + (if (string=? state "COMPLETED") + status + state)) + (iup:attribute-set! *runs-matrix* (conc "BGCOLOR" rownum ":" colnum) (gutils:get-color-for-state-status state status)) + )) + tests))) + run-ids) + + (iup:attribute-set! *runs-matrix* "REDRAW" "ALL") + ;; (debug:print 2 "run-changes: " run-changes) + ;; (debug:print 2 "test-changes: " test-changes) + (list run-changes test-changes))) + +(define (newdashboard) + (let* ((data (make-hash-table)) + (keys (cdb:remote-run db:get-keys #f)) + (runname "%") + (testpatt "%") + (keypatts (map (lambda (k)(list (vector-ref k 0) "%")) keys)) + (states '()) + (statuses '()) + (nextmintime (current-milliseconds))) + (iup:show (main-panel)) + (iup:callback-set! *tim* + "ACTION_CB" + (lambda (x) + ;; Want to dedicate no more than 50% of the time to this so skip if + ;; 2x delta time has not passed since last query + (if (< nextmintime (current-milliseconds)) + (let* ((starttime (current-milliseconds)) + (changes (run-update keys data runname keypatts testpatt states statuses 'full)) + (endtime (current-milliseconds))) + (set! nextmintime (+ endtime (* 2 (- endtime starttime)))) + (debug:print 11 "CHANGE(S): " (car changes) "...")) + (debug:print-info 11 "Server overloaded")))))) + +(newdashboard) +(iup:main-loop) DELETED rpc-transport.scm Index: rpc-transport.scm ================================================================== --- rpc-transport.scm +++ /dev/null @@ -1,381 +0,0 @@ - -;; Copyright 2006-2012, 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. - -(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 server)) - -(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") - -(define (rpc-server:make-server-url hostport) - (if (not hostport) - #f - (conc "http://" (car hostport) ":" (cadr hostport)))) - -(define *server-loop-heart-beat* (current-seconds)) -(define *heartbeat-mutex* (make-mutex)) - -;;====================================================================== -;; S E R V E R -;;====================================================================== - -;; Call this to start the actual server -;; - -(define *db:process-queue-mutex* (make-mutex)) - -(define (rpc-server:run hostn) - (debug:print 2 "Attempting to start the server ...") - (if (not *toppath*) - (if (not (setup-for-run)) - (begin - (debug:print 0 "ERROR: cannot find megatest.config, cannot start server, exiting") - (exit)))) - (let* (;; (iface (if (string=? "-" hostn) - ;; #f ;; (get-host-name) - ;; hostn)) - (db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily - (hostname (get-host-name)) - (ipaddrstr (let ((ipstr (if (string=? "-" hostn) - (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") - #f))) - (if ipstr ipstr hostn))) ;; hostname))) - (start-port (if (args:get-arg "-port") - (string->number (args:get-arg "-port")) - (+ 5000 (random 1001)))) - (link-tree-path (config-lookup *configdat* "setup" "linktree"))) - (set! *cache-on* #t) - (root-path (if link-tree-path - link-tree-path - (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP! - - ;; Setup the web server and a /ctrl interface - ;; - (vhost-map `(((* any) . ,(lambda (continue) - ;; open the db on the first call - (if (not db)(set! db (open-db))) - (let* (($ (request-vars source: 'both)) - (dat ($ 'dat)) - (res #f)) - (cond - ((equal? (uri-path (request-uri (current-request))) - '(/ "hey")) - (send-response body: "hey there!\n" - headers: '((content-type text/plain)))) - ;; This is the /ctrl path where data is handed to the server and - ;; responses - ((equal? (uri-path (request-uri (current-request))) - '(/ "ctrl")) - (let* ((packet (db:string->obj dat)) - (qtype (cdb:packet-get-qtype packet))) - (debug:print-info 12 "server=> received packet=" packet) - (if (not (member qtype '(sync ping))) - (begin - (mutex-lock! *heartbeat-mutex*) - (set! *last-db-access* (current-seconds)) - (mutex-unlock! *heartbeat-mutex*))) - ;; (mutex-lock! *db:process-queue-mutex*) ;; trying a mutex - ;; (set! res (open-run-close db:process-queue-item open-db packet)) - (set! res (db:process-queue-item db packet)) - ;; (mutex-unlock! *db:process-queue-mutex*) - (debug:print-info 11 "Return value from db:process-queue-item is " res) - (send-response body: (conc "ctrl data\n" - res - "") - headers: '((content-type text/plain))))) - (else (continue)))))))) - (server:try-start-server ipaddrstr start-port) - ;; lite3:finalize! db))) - )) - - - -;; (define (rpc-server:main-loop) -;; (print "INFO: Exectuing main server loop") -;; (access-log "megatest-http.log") -;; (server-bind-address #f) -;; (define-page (main-page-path) -;; (lambda () -;; (let ((dat ($ "dat"))) -;; ;; (with-request-variables (dat) -;; (debug:print-info 12 "Got dat=" dat) -;; (let* ((packet (db:string->obj dat)) -;; (qtype (cdb:packet-get-qtype packet))) -;; (debug:print-info 12 "server=> received packet=" packet) -;; (if (not (member qtype '(sync ping))) -;; (begin -;; (mutex-lock! *heartbeat-mutex*) -;; (set! *last-db-access* (current-seconds)) -;; (mutex-unlock! *heartbeat-mutex*))) -;; (let ((res (open-run-close db:process-queue-item open-db packet))) -;; (debug:print-info 11 "Return value from db:process-queue-item is " res) -;; res)))))) - -;;; (use spiffy uri-common intarweb) -;;; -;;; (root-path "/var/www") -;;; -;;; (vhost-map `(((* any) . ,(lambda (continue) -;;; (if (equal? (uri-path (request-uri (current-request))) -;;; '(/ "hey")) -;;; (send-response body: "hey there!\n" -;;; headers: '((content-type text/plain))) -;;; (continue)))))) -;;; -;;; (start-server port: 12345) - -;; This is recursively run by server:run until sucessful -;; -(define (rpc-server:try-start-server ipaddrstr portnum) - (handle-exceptions - exn - (begin - (print-error-message exn) - (if (< portnum 9000) - (begin - (print "WARNING: failed to start on portnum: " portnum ", trying next port") - (thread-sleep! 0.1) - (open-run-close tasks:remove-server-records tasks:open-db) - (server:try-start-server ipaddrstr (+ portnum 1))) - (print "ERROR: Tried and tried but could not start the server"))) - (set! *runremote* (list ipaddrstr portnum)) - (open-run-close tasks:remove-server-records tasks:open-db) - (open-run-close tasks:server-register - tasks:open-db - (current-process-id) - ipaddrstr portnum 0 'live) - (print "INFO: Trying to start server on " ipaddrstr ":" portnum) - ;; This starts the spiffy server - (start-server port: portnum) - (print "INFO: server has been stopped"))) - -(define (rpc-server:mk-signature) - (message-digest-string (md5-primitive) - (with-output-to-string - (lambda () - (write (list (current-directory) - (argv))))))) - -;;====================================================================== -;; S E R V E R U T I L I T I E S -;;====================================================================== - -;; When using zmq this would send the message back (two step process) -;; with spiffy or rpc this simply returns the return data to be returned -;; -(define (rpc-server:reply return-addr query-sig success/fail result) - (debug:print-info 11 "server:reply return-addr=" return-addr ", result=" result) - ;; (send-message pubsock target send-more: #t) - ;; (send-message pubsock - (db:obj->string (vector success/fail query-sig result))) - -;;====================================================================== -;; C L I E N T S -;;====================================================================== - -;; -;; -;; 1 Hello, world! Goodbye Dolly -;; Send msg to serverdat and receive result -(define (rpc-server:client-send-receive serverdat msg) - (let* ((url (server:make-server-url serverdat)) - (fullurl (conc url "/ctrl")) ;; (conc url "/?dat=" msg))) - (numretries 0)) - (handle-exceptions - exn - (if (< numretries 200) - (server:client-send-receive serverdat msg)) - (begin - (debug:print-info 11 "fullurl=" fullurl "\n") - ;; set up the http-client here - (max-retry-attempts 100) - (retry-request? (lambda (request) - (thread-sleep! (/ (if (> numretries 100) 100 numretries) 10)) - (set! numretries (+ numretries 1)) - #t)) - ;; send the data and get the response - ;; extract the needed info from the http data and - ;; process and return it. - (let* ((res (with-input-from-request fullurl - ;; #f - ;; msg - (list (cons 'dat msg)) - read-string))) - (debug:print-info 11 "got res=" res) - (let ((match (string-search (regexp "(.*)<.body>") res))) - (debug:print-info 11 "match=" match) - (let ((final (cadr match))) - (debug:print-info 11 "final=" final) - final))))))) - -(define (client:login serverdat serverdat) - (max-retry-attempts 100) - (cdb:login serverdat *toppath* (client:get-signature))) - -;; Not currently used! But, I think it *should* be used!!! -(define (client:logout serverdat) - (let ((ok (and (socket? serverdat) - (cdb:logout serverdat *toppath* (client:get-signature))))) - ;; (close-socket serverdat) - ok)) - -(define (rpc-server:client-connect iface port) - (let* ((login-res #f) - (serverdat (list iface port))) - (set! login-res (client:login serverdat serverdat)) - (if (and (not (null? login-res)) - (car login-res)) - (begin - (debug:print-info 2 "Logged in and connected to " iface ":" port) - (set! *runremote* serverdat) - serverdat) - (begin - (debug:print-info 2 "Failed to login or connect to " iface ":" port) - (set! *runremote* #f) - #f)))) - -;; Do all the connection work, start a server if not already running -(define (client:setup #!key (numtries 50)) - (if (not *toppath*) - (if (not (setup-for-run)) - (begin - (debug:print 0 "ERROR: failed to find megatest.config, exiting") - (exit)))) - (let ((hostinfo (open-run-close tasks:get-best-server tasks:open-db))) - (if hostinfo - (let ((host (list-ref hostinfo 0)) - (iface (list-ref hostinfo 1)) - (port (list-ref hostinfo 2)) - (pid (list-ref hostinfo 3))) - (debug:print-info 2 "Setting up to connect to " hostinfo) - (server:client-connect iface port)) ;; ) - (if (> numtries 0) - (let ((exe (car (argv))) - (pid #f)) - (debug:print-info 0 "No server available, attempting to start one...") - (set! pid (process-run exe (list "-server" "-" "-debug" (if (list? *verbosity*) - (string-intersperse *verbosity* ",") - (conc *verbosity*))))) - ;; (set! pid (process-fork (lambda () - ;; (current-input-port (open-input-file "/dev/null")) - ;; (current-output-port (open-output-file "/dev/null")) - ;; (current-error-port (open-output-file "/dev/null")) - ;; (server:launch)))) - (let loop ((count 0)) - (let ((hostinfo (open-run-close tasks:get-best-server tasks:open-db))) - (if (not hostinfo) - (begin - (debug:print-info 0 "Waiting for server pid=" pid " to start") - (sleep 2) ;; give server time to start - (if (< count 5) - (loop (+ count 1))))))) - ;; we are starting a server, do not try again! That can lead to - ;; recursively starting many processes!!! - (client:setup numtries: 0)) - (debug:print-info 1 "Too many attempts, giving up"))))) - -;; run server:keep-running in a parallel thread to monitor that the db is being -;; used and to shutdown after sometime if it is not. -;; -(define (rpc-server:keep-running) - ;; if none running or if > 20 seconds since - ;; server last used then start shutdown - ;; This thread waits for the server to come alive - (let* ((server-info (let loop () - (let ((sdat #f)) - (mutex-lock! *heartbeat-mutex*) - (set! sdat *runremote*) - (mutex-unlock! *heartbeat-mutex*) - (if sdat sdat - (begin - (sleep 4) - (loop)))))) - (iface (car server-info)) - (port (cadr server-info)) - (last-access 0) - (tdb (tasks:open-db)) - (spid (tasks:server-get-server-id tdb #f iface port #f))) - (print "Keep-running got server pid " spid ", using iface " iface " and port " port) - (let loop ((count 0)) - (thread-sleep! 4) ;; no need to do this very often - ;; NB// sync currently does NOT return queue-length - (let () ;; (queue-len (cdb:client-call server-info 'sync #t 1))) - ;; (print "Server running, count is " count) - (if (< count 1) ;; 3x3 = 9 secs aprox - (loop (+ count 1))) - - ;; NOTE: Get rid of this mechanism! It really is not needed... - (tasks:server-update-heartbeat tdb spid) - - ;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access - (mutex-lock! *heartbeat-mutex*) - (set! last-access *last-db-access*) - (mutex-unlock! *heartbeat-mutex*) - (if (> (+ last-access - ;; (* 50 60 60) ;; 48 hrs - ;; 60 ;; one minute - ;; (* 60 60) ;; one hour - (* 45 60) ;; 45 minutes, until the db deletion bug is fixed. - ) - (current-seconds)) - (begin - (debug:print-info 2 "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) - (loop 0)) - (begin - (debug:print-info 0 "Starting to shutdown the server.") - ;; need to delete only *my* server entry (future use) - (set! *time-to-exit* #t) - (tasks:server-deregister-self tdb (get-host-name)) - (thread-sleep! 1) - (debug:print-info 0 "Max cached queries was " *max-cache-size*) - (debug:print-info 0 "Server shutdown complete. Exiting") - (exit))))))) - -;; all routes though here end in exit ... -(define (rpc-server:launch) - (if (not *toppath*) - (if (not (setup-for-run)) - (begin - (debug:print 0 "ERROR: cannot find megatest.config, exiting") - (exit)))) - (debug:print-info 2 "Starting the standalone server") - (let ((hostinfo (open-run-close tasks:get-best-server tasks:open-db))) - (debug:print 11 "server:launch hostinfo=" hostinfo) - (if hostinfo - (debug:print-info 2 "NOT starting new server, one is already running on " (car hostinfo) ":" (cadr hostinfo)) - (if *toppath* - (let* ((th2 (make-thread (lambda () - (server:run - (if (args:get-arg "-server") - (args:get-arg "-server") - "-"))) "Server run")) - (th3 (make-thread (lambda ()(server:keep-running)) "Keep running")) - ) - (thread-start! th2) - (thread-start! th3) - (set! *didsomething* #t) - (thread-join! th2) - ) - (debug:print 0 "ERROR: Failed to setup for megatest"))) - (exit))) - Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -17,10 +17,11 @@ (declare (unit server)) (declare (uses common)) (declare (uses db)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. +(declare (uses synchash)) (declare (uses http-transport)) (declare (uses zmq-transport)) (include "common_records.scm") (include "db_records.scm") @@ -38,87 +39,67 @@ ;;====================================================================== ;; Call this to start the actual server ;; -(define *db:process-queue-mutex* (make-mutex)) - -(define (server:run hostn) - (debug:print 2 "Attempting to start the server ...") +;; all routes though here end in exit ... +(define (server:launch transport) (if (not *toppath*) (if (not (setup-for-run)) (begin - (debug:print 0 "ERROR: cannot find megatest.config, cannot start server, exiting") + (debug:print 0 "ERROR: cannot find megatest.config, exiting") (exit)))) - (let* (;; (iface (if (string=? "-" hostn) - ;; #f ;; (get-host-name) - ;; hostn)) - (db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily - (hostname (get-host-name)) - (ipaddrstr (let ((ipstr (if (string=? "-" hostn) - (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") - #f))) - (if ipstr ipstr hostn))) ;; hostname))) - (start-port (if (args:get-arg "-port") - (string->number (args:get-arg "-port")) - (+ 5000 (random 1001)))) - (link-tree-path (config-lookup *configdat* "setup" "linktree"))) - (set! *cache-on* #t) - (root-path (if link-tree-path - link-tree-path - (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP! - - ;; Setup the web server and a /ctrl interface - ;; - (vhost-map `(((* any) . ,(lambda (continue) - ;; open the db on the first call - (if (not db)(set! db (open-db))) - (let* (($ (request-vars source: 'both)) - (dat ($ 'dat)) - (res #f)) - (cond - ((equal? (uri-path (request-uri (current-request))) - '(/ "hey")) - (send-response body: "hey there!\n" - headers: '((content-type text/plain)))) - ;; This is the /ctrl path where data is handed to the server and - ;; responses - ((equal? (uri-path (request-uri (current-request))) - '(/ "ctrl")) - (let* ((packet (db:string->obj dat)) - (qtype (cdb:packet-get-qtype packet))) - (debug:print-info 12 "server=> received packet=" packet) - (if (not (member qtype '(sync ping))) - (begin - (mutex-lock! *heartbeat-mutex*) - (set! *last-db-access* (current-seconds)) - (mutex-unlock! *heartbeat-mutex*))) - ;; (mutex-lock! *db:process-queue-mutex*) ;; trying a mutex - ;; (set! res (open-run-close db:process-queue-item open-db packet)) - (set! res (db:process-queue-item db packet)) - ;; (mutex-unlock! *db:process-queue-mutex*) - (debug:print-info 11 "Return value from db:process-queue-item is " res) - (send-response body: (conc "ctrl data\n" - res - "") - headers: '((content-type text/plain))))) - (else (continue)))))))) - (server:try-start-server ipaddrstr start-port) - ;; lite3:finalize! db))) - )) - - + (debug:print-info 2 "Starting server using " transport " transport") + (set! *transport-type* transport) + (case transport + ((fs) (exit)) ;; there is no "fs" transport + ((http) (http-transport:launch)) + ((zmq) (zmq-transport:launch)) + (else + (debug:print "WARNING: unrecognised transport " transport) + (exit)))) + +;;====================================================================== +;; Q U E U E M A N A G E M E N T +;;====================================================================== + +;; We don't want to flush the queue if it was just flushed +(define *server:last-write-flush* (current-milliseconds)) + +;; Flush the queue every third of a second. Can we assume that setup-for-run +;; has already been done? +(define (server:write-queue-handler) + (if (setup-for-run) + (let ((db (open-db))) + (let loop () + (let ((last-write-flush-time #f)) + (mutex-lock! *incoming-mutex*) + (set! last-write-flush-time *server:last-write-flush*) + (mutex-unlock! *incoming-mutex*) + (if (> (- (current-milliseconds) last-write-flush-time) 400) + (begin + (mutex-lock! *db:process-queue-mutex*) + (db:process-cached-writes db) + (mutex-unlock! *db:process-queue-mutex*) + (thread-sleep! 0.5)))) + (loop))) + (begin + (debug:print 0 "ERROR: failed to setup for Megatest in server:write-queue-handler") + (exit 1)))) + +;;====================================================================== +;; S E R V E R U T I L I T I E S +;;====================================================================== + +;; Generate a unique signature for this server (define (server:mk-signature) (message-digest-string (md5-primitive) (with-output-to-string (lambda () (write (list (current-directory) (argv))))))) -;;====================================================================== -;; S E R V E R U T I L I T I E S -;;====================================================================== ;; When using zmq this would send the message back (two step process) ;; with spiffy or rpc this simply returns the return data to be returned ;; (define (server:reply return-addr query-sig success/fail result) @@ -134,24 +115,5 @@ (send-message pub-socket (db:obj->string (vector success/fail query-sig result))))) (else (debug:print 0 "ERROR: unrecognised transport type: " *transport-type*) result))) - - -;; all routes though here end in exit ... -(define (server:launch transport) - (if (not *toppath*) - (if (not (setup-for-run)) - (begin - (debug:print 0 "ERROR: cannot find megatest.config, exiting") - (exit)))) - (debug:print-info 2 "Starting server using " transport " transport") - (set! *transport-type* transport) - (case transport - ((fs) (exit)) ;; there is no "fs" transport - ((http) (http-transport:launch)) - ((zmq) (zmq-transport:launch)) - (else - (debug:print "WARNING: unrecognised transport " transport) - (exit)))) - ADDED synchash.scm Index: synchash.scm ================================================================== --- /dev/null +++ synchash.scm @@ -0,0 +1,121 @@ +;;====================================================================== +;; Copyright 2006-2012, 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. +;;====================================================================== + +;;====================================================================== +;; A hash of hashes that can be kept in sync by sending minial deltas +;;====================================================================== + +(use format) +(use srfi-1 srfi-69) + +(declare (unit synchash)) +(declare (uses db)) +(declare (uses server)) +(include "db_records.scm") + +(define (synchash:make) + (make-hash-table)) + +;; given an alist of objects '((id obj) ...) +;; 1. remove unchanged objects from the list +;; 2. create a list of removed objects by id +;; 3. remove removed objects from synchash +;; 4. replace or add new or changed objects to synchash +;; +(define (synchash:get-delta indat synchash) + (let ((deleted '()) + (changed '()) + (found '()) + (orig-keys (hash-table-keys synchash))) + (for-each + (lambda (item) + (let* ((id (car item)) + (dat (cadr item)) + (ref (hash-table-ref/default synchash id #f))) + (if (not (equal? dat ref)) ;; item changed or new + (begin + (set! changed (cons item changed)) + (hash-table-set! synchash id dat))) + (set! found (cons id found)))) + indat) + (for-each + (lambda (id) + (if (not (member id found)) + (begin + (set! deleted (cons id deleted)) + (hash-table-delete! synchash id)))) + orig-keys) + (list changed deleted) + ;; (list indat '()) ;; just for debugging + )) + +;; (cdb:remote-run db:get-keys #f) +;; (cdb:remote-run db:get-num-runs #f "%") +;; (cdb:remote-run db:get-runs #f runnamepatt numruns *start-run-offset* keypatts) +;; +;; keynum => the field to use as the unique key (usually 0 but can be other field) +;; +(define (synchash:client-get proc synckey keynum synchash . params) + (let* ((data (apply cdb:remote-run synchash:server-get #f proc synckey keynum params)) + (newdat (car data)) + (removs (cadr data)) + (myhash (hash-table-ref/default synchash synckey #f))) + (if (not myhash) + (begin + (set! myhash (make-hash-table)) + (hash-table-set! synchash synckey myhash))) + (for-each + (lambda (item) + (let ((id (car item)) + (dat (cadr item))) + ;; (debug:print-info 2 "Processing item: " item) + (hash-table-set! myhash id dat))) + newdat) + (for-each + (lambda (id) + (hash-table-delete! myhash id)) + removs) + ;; WHICH ONE!? + ;; data)) ;; return the changed and deleted list + (list newdat removs))) ;; synchash)) + +(define *synchashes* (make-hash-table)) + +(define (synchash:server-get db proc synckey keynum . params) + ;; (debug:print-info 2 "synckey: " synckey ", keynum: " keynum ", params: " params) + (let* ((synchash (hash-table-ref/default *synchashes* synckey #f)) + (newdat (apply (case proc + ((db:get-runs) db:get-runs) + ((db:get-tests-for-runs-mindata) db:get-tests-for-runs-mindata) + (else print)) + db params)) + (postdat #f) + (make-indexed (lambda (x) + (list (vector-ref x keynum) x)))) + ;; Now process newdat based on the query type + (set! postdat (case proc + ((db:get-runs) + ;; (debug:print-info 2 "Get runs call") + (let ((header (vector-ref newdat 0)) + (data (vector-ref newdat 1))) + ;; (debug:print-info 2 "header: " header ", data: " data) + (cons (list "header" header) ;; add the header keyed by the word "header" + (map make-indexed data)))) ;; add each element keyed by the keynum'th val + (else + ;; (debug:print-info 2 "Non-get runs call") + (map make-indexed newdat)))) + ;; (debug:print-info 2 "postdat: " postdat) + (if (not synchash) + (begin + (set! synchash (make-hash-table)) + (hash-table-set! *synchashes* synckey synchash))) + (synchash:get-delta postdat synchash))) + Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -192,15 +192,17 @@ (let ((res '()) (best #f)) (sqlite3:for-each-row (lambda (id interface port pubport transport pid hostname) (set! res (cons (vector id interface port pubport transport pid hostname) res)) - (debug:print-info 2 "Found existing server " hostname ":" port " registered in db")) + ;;(debug:print-info 2 "Found existing server " hostname ":" port " registered in db")) + ) mdb - ;; strftime('%s','now')-heartbeat < 10 AND + "SELECT id,interface,port,pubport,transport,pid,hostname FROM servers - WHERE mt_version=? ORDER BY start_time DESC LIMIT 1;" megatest-version) + WHERE strftime('%s','now')-heartbeat < 10 + AND mt_version=? ORDER BY start_time DESC LIMIT 1;" megatest-version) ;; for now we are keeping only one server registered in the db, return #f or first server found (if (null? res) #f (car res)))) ;; BUG: This logic is probably needed unless methodology changes completely... ;; Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -19,10 +19,11 @@ TARGET = "-target ubuntu/nfs/none" all : test1 test2 test3 test4 test5 server : + (cd ..;make;make install) && \ (cd fullrun;../../bin/megatest -server - -debug 22) & test0 : cleanprep cd simplerun ; $(MEGATEST) -server - -debug $(DEBUG)& @@ -63,11 +64,11 @@ cd fullrun;$(MEGATEST) -rollup :runname newrun -target ubuntu/nfs/none -debug 10 cleanprep : ../*.scm Makefile */*.config mkdir -p /tmp/mt_runs /tmp/mt_links - cd ..;make install + cd ..;make;make install rm -f */logging.db touch cleanprep fullprep : cleanprep cd fullrun;$(MEGATEST) -remove-runs :runname $(RUNNAME)% -target %/%/% -testpatt %/% Index: tests/fullrun/config/mt_include_1.config ================================================================== --- tests/fullrun/config/mt_include_1.config +++ tests/fullrun/config/mt_include_1.config @@ -1,8 +1,9 @@ [setup] # exectutable /path/to/megatest -max_concurrent_jobs 60 +max_concurrent_jobs 200 + linktree #{getenv MT_RUN_AREA_HOME}/tmp/mt_links [jobtools] useshell yes # ## launcher launches jobs, the job is managed on the target host Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -42,10 +42,20 @@ EMPTY_VAR # XTERM [system xterm] # RUNDEAD [system exit 56] +[server] + +# If the server can't be started on this port it will try the next port until +# it succeeds +port 8090 + +# This server will keep running this number of hours after last access. +# Three minutes is 0.05 hours +timeout 0.05 + ## disks are: ## name host:/path/to/area ## -or- ## name /path/to/area [disks]