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))) @@ -916,10 +976,12 @@ (define (db:clean-all-caches) (set! *test-info* (make-hash-table)) (set! *test-id-cache* (make-hash-table))) +;; Use db:test-get* to access +;; ;; Get test data using test_id (define (db:get-test-info-by-id db test-id) (if (not test-id) (begin (debug:print-info 4 "db:get-test-info-by-id called with test-id=" test-id) @@ -931,10 +993,29 @@ (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment))) db "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment FROM tests WHERE id=?;" test-id) res))) + +;; Use db:test-get* to access +;; +;; Get test data using test_ids +(define (db:get-test-info-by-ids db test-ids) + (if (null? test-ids) + (begin + (debug:print-info 4 "db:get-test-info-by-ids called with test-ids=" test-ids) + '()) + (let ((res '())) + (sqlite3:for-each-row + (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment) + ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 + (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment) + res))) + db + (conc "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment FROM tests WHERE id in (" + (string-intersperse (map conc test-ids) ",") ");")) + res))) (define (db:get-test-info db run-id testname item-path) (db:get-test-info-by-id db (db:get-test-id db run-id testname item-path))) (define (db:test-set-comment db test-id comment) @@ -1038,21 +1119,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 +1322,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,145 @@ + +(use test) +(require-library iup) +(import (prefix iup iup:)) + +(define t #f) + +(define tree-dialog + (iup:dialog + #:title "Tree Test" + (let ((t1 (iup:treebox + #:selection_cb (lambda (obj id state) + (print "selection_db with id=" id " state=" state) + (print "USERDATA: " (iup:attribute obj "USERDATA")) + (print "SPECIALDATA: " (iup:attribute obj "SPECIALDATA")) + (print "Depth: " (iup:attribute obj "DEPTH")) + )))) + (set! t t1) + t1))) + +(iup:show tree-dialog) + +(map (lambda (elname el) + (print "Adding " elname " with value " el) + (iup:attribute-set! t elname el) + (iup:attribute-set! t "USERDATA" el)) + '("VALUE" "NAME" "ADDLEAF" "ADDBRANCH1" "ADDLEAF2" "VALUE") + '("0" "Figures" "Other" "triangle" "equilateral" "4") + ) +(map (lambda (attr) + (print attr " is " (iup:attribute t attr))) + '("KIND1" "PARENT2" "STATE1")) + +(define (tree-find-node obj path) + ;; start at the base of the tree + (if (null? path) + #f ;; or 0 ???? + (let loop ((hed (car path)) + (tal (cdr path)) + (depth 0) + (nodenum 0)) + ;; nodes in iup tree are 100% sequential so iterate over nodenum + (if (iup:attribute obj (conc "DEPTH" nodenum)) ;; end when no more nodes + (let ((node-depth (string->number (iup:attribute obj (conc "DEPTH" nodenum)))) + (node-title (iup:attribute obj (conc "TITLE" nodenum)))) + ;; (print 0 "hed: " hed ", depth: " depth ", node-depth: " node-depth ", nodenum: " nodenum ", node-title: " node-title) + (if (and (equal? depth node-depth) + (equal? hed node-title)) ;; yep, this is the one! + (if (null? tal) ;; end of the line + nodenum + (loop (car tal)(cdr tal)(+ depth 1)(+ 1 nodenum))) + ;; this is the case where we found part of the hierarchy but not + ;; all of it, i.e. the node-depth went from deep to less deep + (if (> depth node-depth) ;; (+ 1 node-depth)) + #f + (loop hed tal depth (+ nodenum 1))))) + #f)))) + +;; top is the top node name zeroeth node VALUE=0 +(define (tree-add-node obj top nodelst) + (if (not (iup:attribute obj "TITLE0")) + (iup:attribute-set! obj "ADDBRANCH0" top)) + (cond + ((not (string=? top (iup:attribute obj "TITLE0"))) + (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0"))) + ((null? nodelst)) + (else + (let loop ((hed (car nodelst)) + (tal (cdr nodelst)) + (depth 1) + (pathl (list top))) + ;; Because the tree dialog changes node numbers when + ;; nodes are added or removed we must look up nodes + ;; each and every time. 0 is the top node so default + ;; to that. + (let* ((newpath (append pathl (list hed))) + (parentnode (tree-find-node obj pathl)) + (nodenum (tree-find-node obj newpath))) + ;; (print "newpath: " newpath ", nodenum " nodenum ", hed: " hed ", depth: " depth ", parentnode: " parentnode ", pathl: " pathl) + ;; Add the branch under lastnode if not found + (if (not nodenum) + (begin + (iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed) + (if (null? tal) + #t + ;; reset to top + (loop (car nodelst)(cdr nodelst) 1 (list top)))) + (if (null? tal) ;; if null here then this path has already been added + #t + ;; (if nodenum + (loop (car tal)(cdr tal)(+ depth 1) newpath)))))))) ;; (if nodenum nodenum lastnode))))))) + ;; (loop hed tal depth pathl lastnode))))))) + +(define (tree-node->path obj nodenum) + ;; (print "\ncurrnode nodenum depth node-depth node-title path") + (let loop ((currnode 0) + (depth 0) + (path '())) + (let ((node-depth (iup:attribute obj (conc "DEPTH" currnode))) + (node-title (iup:attribute obj (conc "TITLE" currnode)))) + ;; (display (conc "\n "currnode " " nodenum " " depth " " node-depth " " node-title " " path)) + (if (> currnode nodenum) + path + (if (not node-depth) ;; #f if we are out of nodes + '() + (let ((ndepth (string->number node-depth))) + (if (eq? ndepth depth) + ;; This next is the match condition depth == node-depth + (if (eq? currnode nodenum) + (begin + ;; (display " ") + (append path (list node-title))) + (loop (+ currnode 1) + (+ depth 1) + (append path (list node-title)))) + ;; didn't match, reset to base path and keep looking + ;; due to more iup odditys we don't reset to base + (begin + ;; (display " ") + (loop (+ 1 currnode) + 2 + (append (take path ndepth)(list node-title))))))))))) + +(test #f 0 (tree-find-node t '("Figures"))) +(test #f 1 (tree-find-node t '("Figures" "Other"))) +(test #f #f (tree-find-node t '("Figures" "Other" "equilateral"))) +(test #f 3 (tree-find-node t '("Figures" "triangle" "equilateral"))) +(test #f #t (tree-add-node t "Figures" '())) +(test #f #t (tree-add-node t "Figures" '("a" "b" "c"))) +(test #f 3 (tree-find-node t '("Figures" "a" "b" "c"))) +(test #f #t (tree-add-node t "Figures" '("d" "b" "c"))) +(test #f 3 (tree-find-node t '("Figures" "d" "b" "c"))) +(test #f 6 (tree-find-node t '("Figures" "a" "b" "c"))) +(test #f #t (tree-add-node t "Figures" '("a" "e" "c"))) +(test #f 6 (tree-find-node t '("Figures" "a" "e" "c"))) + +(test #f '("Figures") (tree-node->path t 0)) +(test #f '("Figures" "d") (tree-node->path t 1)) +(test #f '("Figures" "d" "b" "c") (tree-node->path t 3)) +(test #f '("Figures" "a") (tree-node->path t 4)) +(test #f '("Figures" "a" "b" "c") (tree-node->path t 8)) +(test #f '() (tree-node->path t 40)) + +(iup:main-loop) + Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -32,11 +32,11 @@ (include "key_records.scm") (include "db_records.scm") (include "megatest-fossil-hash.scm") (define help (conc " -Megatest, documentation at http://www.kiatoa.com/fossils/megatest +Megatest, documentation at http://chiselapp.com/user/kiatoa/repository/megatest version " megatest-version " license GPL, Copyright Matt Welland 2006-2012 Usage: megatest [options] -h : this help ADDED newdashboard.scm Index: newdashboard.scm ================================================================== --- /dev/null +++ newdashboard.scm @@ -0,0 +1,926 @@ +;;====================================================================== +;; 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) + +(define *data* (make-vector 10 #f)) +(define-inline (dboard:data-get-runs vec) (vector-ref vec 0)) +(define-inline (dboard:data-get-tests vec) (vector-ref vec 1)) +(define-inline (dboard:data-get-runs-matrix vec) (vector-ref vec 2)) +(define-inline (dboard:data-get-tests-tree vec) (vector-ref vec 3)) +(define-inline (dboard:data-get-run-keys vec) (vector-ref vec 4)) +(define-inline (dboard:data-get-curr-test-ids vec) (vector-ref vec 5)) +;; (define-inline (dboard:data-get-test-details vec) (vector-ref vec 6)) +(define-inline (dboard:data-get-path-test-ids vec) (vector-ref vec 7)) +(define-inline (dboard:data-get-updaters vec) (vector-ref vec 8)) + +(define-inline (dboard:data-set-runs! vec val)(vector-set! vec 0 val)) +(define-inline (dboard:data-set-tests! vec val)(vector-set! vec 1 val)) +(define-inline (dboard:data-set-runs-matrix! vec val)(vector-set! vec 2 val)) +(define-inline (dboard:data-set-tests-tree! vec val)(vector-set! vec 3 val)) +(define-inline (dboard:data-set-run-keys! vec val)(vector-set! vec 4 val)) +(define-inline (dboard:data-set-curr-test-ids! vec val)(vector-set! vec 5 val)) +;; (define-inline (dboard:data-set-test-details! vec val)(vector-set! vec 6 val)) +(define-inline (dboard:data-set-path-test-ids! vec val)(vector-set! vec 7 val)) +(define-inline (dboard:data-set-updaters! vec val)(vector-set! vec 8 val)) + +(dboard:data-set-run-keys! *data* (make-hash-table)) + +;; List of test ids being viewed in various panels +(dboard:data-set-curr-test-ids! *data* (make-hash-table)) + +;; Look up test-ids by (key1 key2 ... testname [itempath]) +(dboard:data-set-path-test-ids! *data* (make-hash-table)) + +;; Each test panel has an updater, only call when the tab is exposed +(dboard:data-set-updaters! *data* (make-hash-table)) + +(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 + ;; ) + )))) + +;; mtest is actually the megatest.config file +;; +(define (mtest window-id) + (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)) + )))) + +;; The runconfigs.config file +;; +(define (rconfig window-id) + (iup:vbox + (iup:frame #:title "Default"))) + +;;====================================================================== +;; T R E E S T U F F +;;====================================================================== + +;; path is a list of nodes, each the child of the previous +;; this routine returns the id so another node can be added +;; either as a leaf or as a branch +;; +;; BUG: This needs a stop sensor for when a branch is exhausted +;; +(define (tree-find-node obj path) + ;; start at the base of the tree + (if (null? path) + #f ;; or 0 ???? + (let loop ((hed (car path)) + (tal (cdr path)) + (depth 0) + (nodenum 0)) + ;; nodes in iup tree are 100% sequential so iterate over nodenum + (if (iup:attribute obj (conc "DEPTH" nodenum)) ;; end when no more nodes + (let ((node-depth (string->number (iup:attribute obj (conc "DEPTH" nodenum)))) + (node-title (iup:attribute obj (conc "TITLE" nodenum)))) + (if (and (equal? depth node-depth) + (equal? hed node-title)) ;; yep, this is the one! + (if (null? tal) ;; end of the line + nodenum + (loop (car tal)(cdr tal)(+ depth 1)(+ 1 nodenum))) + ;; this is the case where we found part of the hierarchy but not + ;; all of it, i.e. the node-depth went from deep to less deep + (if (> depth node-depth) ;; (+ 1 node-depth)) + #f + (loop hed tal depth (+ nodenum 1))))) + #f)))) + +;; top is the top node name zeroeth node VALUE=0 +(define (tree-add-node obj top nodelst #!key (userdata #f)) + (if (not (iup:attribute obj "TITLE0")) + (iup:attribute-set! obj "ADDBRANCH0" top)) + (cond + ((not (string=? top (iup:attribute obj "TITLE0"))) + (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0"))) + ((null? nodelst)) + (else + (let loop ((hed (car nodelst)) + (tal (cdr nodelst)) + (depth 1) + (pathl (list top))) + ;; Because the tree dialog changes node numbers when + ;; nodes are added or removed we must look up nodes + ;; each and every time. 0 is the top node so default + ;; to that. + (let* ((newpath (append pathl (list hed))) + (parentnode (tree-find-node obj pathl)) + (nodenum (tree-find-node obj newpath))) + ;; Add the branch under lastnode if not found + (if (not nodenum) + (begin + (iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed) + (if userdata + (iup:attribute-set! obj (conc "USERDATA" parentnode) userdata)) + (if (null? tal) + #t + ;; reset to top + (loop (car nodelst)(cdr nodelst) 1 (list top)))) + (if (null? tal) ;; if null here then this path has already been added + #t + (loop (car tal)(cdr tal)(+ depth 1) newpath)))))))) + +(define (tree-node->path obj nodenum) + ;; (print "\ncurrnode nodenum depth node-depth node-title path") + (let loop ((currnode 0) + (depth 0) + (path '())) + (let ((node-depth (iup:attribute obj (conc "DEPTH" currnode))) + (node-title (iup:attribute obj (conc "TITLE" currnode)))) + ;; (display (conc "\n "currnode " " nodenum " " depth " " node-depth " " node-title " " path)) + (if (> currnode nodenum) + path + (if (not node-depth) ;; #f if we are out of nodes + '() + (let ((ndepth (string->number node-depth))) + (if (eq? ndepth depth) + ;; This next is the match condition depth == node-depth + (if (eq? currnode nodenum) + (begin + ;; (display " ") + (append path (list node-title))) + (loop (+ currnode 1) + (+ depth 1) + (append path (list node-title)))) + ;; didn't match, reset to base path and keep looking + ;; due to more iup odditys we don't reset to base + (begin + ;; (display " ") + (loop (+ 1 currnode) + 2 + (append (take path ndepth)(list node-title))))))))))) + +;;====================================================================== +;; T E S T S +;;====================================================================== + +(define (tree-path->test-id path) + (if (not (null? path)) + (hash-table-ref/default (dboard:data-get-path-test-ids *data*) path #f) + #f)) + +(define (test-panel window-id) + (let* ((curr-row-num 0) + (viewlog (lambda (x) + (if (file-exists? logfile) + ;(system (conc "firefox " logfile "&")) + (iup:send-url logfile) + (message-window (conc "File " logfile " not found"))))) + (xterm (lambda (x) + (if (directory-exists? rundir) + (let ((shell (if (get-environment-variable "SHELL") + (conc "-e " (get-environment-variable "SHELL")) + ""))) + (system (conc "cd " rundir + ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) + (message-window (conc "Directory " rundir " not found"))))) + (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -10")) + (command-launch-button (iup:button "Execute!" #:action (lambda (x) + (let ((cmd (iup:attribute command-text-box "VALUE"))) + (system (conc cmd " &")))))) + (run-test (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "xterm -geometry 180x20 -e \"megatest -target " keystring " :runname " runname + " -runtests " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + ";echo Press any key to continue;bash -c 'read -n 1 -s'\"")))) + (remove-test (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "xterm -geometry 180x20 -e \"megatest -remove-runs -target " keystring " :runname " runname + " -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + " -v;echo Press any key to continue;bash -c 'read -n 1 -s'\"")))) + (run-info-matrix (iup:matrix + #:expand "YES" + ;; #:scrollbar "YES" + #:numcol 1 + #:numlin 4 + #:numcol-visible 1 + #:numlin-visible 4 + #:click-cb (lambda (obj lin col status) + (print "obj: " obj " lin: " lin " col: " col " status: " status)))) + (test-info-matrix (iup:matrix + #:expand "YES" + #:numcol 1 + #:numlin 7 + #:numcol-visible 1 + #:numlin-visible 7)) + (test-run-matrix (iup:matrix + #:expand "YES" + #:numcol 1 + #:numlin 5 + #:numcol-visible 1 + #:numlin-visible 5)) + (meta-dat-matrix (iup:matrix + #:expand "YES" + #:numcol 1 + #:numlin 5 + #:numcol-visible 1 + #:numlin-visible 5)) + (steps-matrix (iup:matrix + #:expand "YES" + #:numcol 5 + #:numlin 50 + #:numcol-visible 5 + #:numlin-visible 8)) + (data-matrix (iup:matrix + #:expand "YES" + #:numcol 8 + #:numlin 50 + #:numcol-visible 8 + #:numlin-visible 8)) + (updater (lambda (testdat) + (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix)))) + + ;; Set the updater in updaters + (hash-table-set! (dboard:data-get-updaters *data*) window-id updater) + ;; + (for-each + (lambda (mat) + ;; (iup:attribute-set! mat "0:1" "Value") + ;; (iup:attribute-set! mat "0:0" "Var") + (iup:attribute-set! mat "HEIGHT0" 0) + (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 run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix)) + + ;; Steps matrix + (iup:attribute-set! steps-matrix "0:1" "Step Name") + (iup:attribute-set! steps-matrix "0:2" "Start") + (iup:attribute-set! steps-matrix "0:3" "End") + (iup:attribute-set! steps-matrix "WIDTH3" "50") + (iup:attribute-set! steps-matrix "0:4" "Status") + (iup:attribute-set! steps-matrix "WIDTH4" "50") + (iup:attribute-set! steps-matrix "0:5" "Log File") + (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") + ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") + (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") + ;; (iup:attribute-set! steps-matrix "WIDTH1" "120") + ;; (iup:attribute-set! steps-matrix "WIDTH0" "100") + + ;; Data matrix + ;; + (let ((rownum 1)) + (for-each + (lambda (x) + (iup:attribute-set! data-matrix (conc "0:" rownum) x) + (iup:attribute-set! data-matrix (conc "WIDTH" rownum) "50") + (set! rownum (+ rownum 1))) + (list "Category" "Variable" "Value" "Expected" "Tolerance" "Status" "Units" "Type" "Comment"))) + (iup:attribute-set! data-matrix "REDRAW" "ALL") + + (for-each + (lambda (data) + (let ((mat (car data)) + (keys (cadr data)) + (rownum 1)) + (for-each + (lambda (key) + (iup:attribute-set! mat (conc rownum ":0") key) + (set! rownum (+ rownum 1))) + keys) + (iup:attribute-set! mat "REDRAW" "ALL"))) + (list + (list run-info-matrix '("Run Id" "Target" "Runname" "Run Start Time" )) + (list test-info-matrix '("Test Id" "Testname" "Itempath" "State" "Status" "Test Start Time" "Comment")) + (list test-run-matrix '("Hostname" "Host info" "Disk Free" "CPU Load" "Run Duration")) + (list meta-dat-matrix '("Author" "Owner" "Last Reviewed" "Tags" "Description")))) + + (iup:vbox + (iup:hbox + run-info-matrix + test-info-matrix) + (iup:hbox + test-run-matrix + meta-dat-matrix) + (iup:vbox + (iup:vbox + (iup:hbox + (iup:button "View Log" #:action viewlog #:size "80x") + (iup:button "Start Xterm" #:action xterm #:size "80x") + (iup:button "Run Test" #:action run-test #:size "80x") + (iup:button "Clean Test" #:action remove-test #:size "80x")) + (apply + iup:hbox + (list command-text-box command-launch-button)))) + (iup:vbox + (let ((tabs (iup:tabs + steps-matrix + data-matrix))) + (iup:attribute-set! tabs "TABTITLE0" "Test Steps") + (iup:attribute-set! tabs "TABTITLE1" "Test Data") + tabs))))) + +;; Test browser +(define (tests window-id) + (iup:hbox + (let* ((tb (iup:treebox + #:selection-cb + (lambda (obj id state) + ;; (print "obj: " obj ", id: " id ", state: " state) + (let* ((run-path (tree-node->path obj id)) + (test-id (tree-path->test-id (cdr run-path)))) + (if test-id + (hash-table-set! (dboard:data-get-curr-test-ids *data*) + window-id test-id)) + (print "path: " (tree-node->path obj id) " test-id: " test-id)))))) + (iup:attribute-set! tb "VALUE" "0") + (iup:attribute-set! tb "NAME" "Runs") + ;;(iup:attribute-set! tb "ADDEXPANDED" "NO") + (dboard:data-set-tests-tree! *data* tb) + tb) + (test-panel window-id))) + +;; The function to update the fields in the test view panel +(define (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix) + ;; get test-id + ;; then get test record + (if testdat + (let* ((test-id (hash-table-ref/default (dboard:data-get-curr-test-ids *data*) window-id #f)) + (test-data (hash-table-ref/default testdat test-id #f)) + (targ/runname (hash-table-ref/default (dboard:data-get-run-keys *data*) + (db:test-get-run_id test-data) '())) + (target (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/"))) + (runname (if (null? targ/runname) "" (car (cdr targ/runname))))) + (if test-data + (begin + ;; + (for-each + (lambda (data) + (let ((mat (car data)) + (vals (cadr data)) + (rownum 1)) + (for-each + (lambda (key) + (let ((cell (conc rownum ":1"))) + (if (not (equal? (iup:attribute mat cell)(conc key))) + (begin + ;; (print "setting cell " cell " in matrix " mat " to value " key) + (iup:attribute-set! mat cell (conc key)) + (iup:attribute-set! mat "REDRAW" cell))) + (set! rownum (+ rownum 1)))) + vals))) + (list + (list run-info-matrix + (if test-id + (list (db:test-get-run_id test-data) + target + runname + "n/a") + (make-list 4 ""))) + (list test-info-matrix + (if test-id + (list test-id + (db:test-get-testname test-data) + (db:test-get-item-path test-data) + (db:test-get-state test-data) + (db:test-get-status test-data) + (seconds->string (db:test-get-event_time test-data)) + (db:test-get-comment test-data)) + (make-list 7 ""))) + (list test-run-matrix + (if test-id + (list (db:test-get-host test-data) + (db:test-get-uname test-data) + (db:test-get-diskfree test-data) + (db:test-get-cpuload test-data) + (seconds->hr-min-sec (db:test-get-run_duration test-data))) + (make-list 5 ""))) + ;;(list meta-dat-matrix + ;; (if test-id + ;; (list ( + ))))))) + + +;; db:test-get-id +;; db:test-get-run_id +;; db:test-get-testname +;; db:test-get-state +;; db:test-get-status +;; db:test-get-event_time +;; db:test-get-host +;; db:test-get-cpuload +;; db:test-get-diskfree +;; db:test-get-uname +;; db:test-get-rundir +;; db:test-get-item-path +;; db:test-get-run_duration +;; db:test-get-final_logf +;; db:test-get-comment +;; db:test-get-fullname + + +;;====================================================================== +;; R U N C O N T R O L +;;====================================================================== + +;; Overall runs browser +;; +(define (runs window-id) + (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! runs-matrix "RESIZEMATRIX" "YES") + (iup:attribute-set! runs-matrix "WIDTH0" "100") + + (dboard:data-set-runs-matrix! *data* runs-matrix) + (iup:hbox + (iup:frame + #:title "Runs browser" + (iup:vbox + runs-matrix))))) + +;; Browse and control a single run +;; +(define (runcontrol window-id) + (iup:hbox)) + +;;====================================================================== +;; P R O C E S S R U N S +;;====================================================================== + +;; MOVE THIS INTO *data* +(define *cachedata* (make-hash-table)) +(hash-table-set! *cachedata* "runid-to-col" (make-hash-table)) +(hash-table-set! *cachedata* "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 window-id) + (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")) + (get-details-sig (conc (client:get-signature) " get-test-details")) + + ;; test-ids to get and display are indexed on window-id in curr-test-ids hash + (test-ids (hash-table-values (dboard:data-get-curr-test-ids *data*))) + + (run-changes (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data runname #f #f keypatts)) + (tests-detail-changes (if (not (null? test-ids)) + (synchash:client-get 'db:get-test-info-by-ids get-details-sig 0 data test-ids) + '())) + + ;; 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 *cachedata* "runid-to-col")) + (testname-to-row (hash-table-ref *cachedata* "testname-to-row")) + (colnum 1) + (rownum 0)) ;; rownum = 0 is the header +;; (debug:print 0 "test-ids " test-ids ", tests-detail-changes " tests-detail-changes) + + ;; 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 + + ;; NOTE: Also build the test tree browser and look up table + ;; + ;; Each run is unique on its keys and runname or run-id, store in hash on colnum + (for-each (lambda (run-id) + (let* ((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)) + (run-path (append key-vals (list run-name)))) + (hash-table-set! (dboard:data-get-run-keys *data*) run-id run-path) + (iup:attribute-set! (dboard:data-get-runs-matrix *data*) + (conc rownum ":" colnum) col-name) + (hash-table-set! runid-to-col run-id (list colnum run-record)) + ;; Here we update the tests treebox and tree keys + (tree-add-node (dboard:data-get-tests-tree *data*) "Runs" (append key-vals (list run-name)) + userdata: (conc "run-id: " run-id)) + (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* ((run-path (hash-table-ref (dboard:data-get-run-keys *data*) run-id)) + (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* ((test-id (db:mintest-get-id test)) + (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)) + (test-path (append run-path (if (equal? itempath "") + (list testname) + (list testname itempath))))) + (tree-add-node (dboard:data-get-tests-tree *data*) "Runs" + test-path + userdata: (conc "test-id: " test-id)) + (hash-table-set! (dboard:data-get-path-test-ids *data*) test-path test-id) + (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! (dboard:data-get-runs-matrix *data*) + (conc rownum ":" 0) dispname) + )) + ;; set the cell text and color + ;; (debug:print 2 "rownum:colnum=" rownum ":" colnum ", state=" status) + (iup:attribute-set! (dboard:data-get-runs-matrix *data*) + (conc rownum ":" colnum) + (if (string=? state "COMPLETED") + status + state)) + (iup:attribute-set! (dboard:data-get-runs-matrix *data*) + (conc "BGCOLOR" rownum ":" colnum) + (gutils:get-color-for-state-status state status)) + )) + tests))) + run-ids) + + (let ((updater (hash-table-ref/default (dboard:data-get-updaters *data*) window-id #f))) + (if updater (updater (hash-table-ref/default data get-details-sig #f)))) + + (iup:attribute-set! (dboard:data-get-runs-matrix *data*) "REDRAW" "ALL") + ;; (debug:print 2 "run-changes: " run-changes) + ;; (debug:print 2 "test-changes: " test-changes) + (list run-changes test-changes))) + +;;====================================================================== +;; D A S H B O A R D +;;====================================================================== + +;; Main Panel +(define (main-panel window-id) + (iup:dialog + #:title "Megatest Control Panel" + #:menu (main-menu) + (let ((tabtop (iup:tabs + (runs window-id) + (tests window-id) + (runcontrol window-id) + (mtest window-id) + (rconfig window-id) + ))) + (iup:attribute-set! tabtop "TABTITLE0" "Runs") + (iup:attribute-set! tabtop "TABTITLE1" "Tests") + (iup:attribute-set! tabtop "TABTITLE2" "Run Control") + (iup:attribute-set! tabtop "TABTITLE3" "megatest.config") + (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config") + tabtop))) + +(define *current-window-id* 0) + +(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)) + (my-window-id *current-window-id*)) + (set! *current-window-id* (+ 1 *current-window-id*)) + (dboard:data-set-runs! *data* data) ;; make this data available to the rest of the application + (iup:show (main-panel my-window-id)) + ;; Yes, running iup:show will pop up a new panel + ;; (iup:show (main-panel my-window-id)) + (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 my-window-id)) + (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,124 @@ +;;====================================================================== +;; 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) + ((db:get-test-info-by-ids) db:get-test-info-by-ids) + (else + (print "ERROR: sync for hash " proc " not setup! Edits needed in synchash.scm") + 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]