Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -485,17 +485,17 @@ (lbs '())) (let* ((lb (let ((lb (list-ref key-listboxes indx))) (if lb lb (iup:listbox - #:size "x15" - #:fontsize "10" - #:expand "YES" - ;; #:dropdown "YES" - #:editbox "YES" - #:action action-proc - )))) + #:size "x10" + #:fontsize "10" + #:expand "VERTICAL" + ;; #:dropdown "YES" + #:editbox "YES" + #:action action-proc + )))) ;; loop though all the targets and build the list for this dropdown (selected-value (dashboard:populate-target-dropdown lb refvals db-targets))) (if (null? remkeys) ;; return a list of the listbox items and an iup:hbox with the labels and listboxes (let ((listboxes (append lbs (list lb)))) @@ -512,11 +512,11 @@ (+ indx 1) (append lbs (list lb)))))))) (define (dashboard:draw-tests cnv xadj yadj test-draw-state sorted-testnames) (canvas-clear! cnv) - (canvas-font-set! cnv "Courier New, -8") + (canvas-font-set! cnv "Courier New, -10") (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) ((originx originy) (canvas-origin cnv))) (if (hash-table-ref/default test-draw-state 'first-time #t) (begin (hash-table-set! test-draw-state 'first-time #f) @@ -527,12 +527,12 @@ (let* ((scalef (hash-table-ref/default test-draw-state 'scalef 8)) (test-browse-xoffset (hash-table-ref test-draw-state 'test-browse-xoffset)) (test-browse-yoffset (hash-table-ref test-draw-state 'test-browse-yoffset)) (xtorig (+ test-browse-xoffset (* (/ sizex 2) scalef (- 0.5 xadj)))) ;; (- xadj 1)))) (ytorig (+ test-browse-yoffset (* (/ sizey 2) scalef (- yadj 0.5)))) - (boxw 80) - (boxh 30) + (boxw 90) + (boxh 25) (gapx 20) (gapy 30)) (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj) (let loop ((hed (car (reverse sorted-testnames))) (tal (cdr (reverse sorted-testnames))) @@ -543,11 +543,14 @@ ; (print "hed " hed " llx " llx " lly " lly " urx " urx " ury " ury) (canvas-text! cnv (+ llx 5)(+ lly 5) hed) ;; (conc testname " (" xtorig "," ytorig ")")) (canvas-rectangle! cnv llx urx lly ury) (if (not (null? tal)) ;; leave a column of space to the right to list items - (let ((have-room (< urx (- sizex boxw gapx boxw)))) ;; is there room for another column? + (let ((have-room + (if #t ;; put "auto" here where some form of auto rearanging can be done + (> (* 3 (+ boxw gapx)) (- urx xtorig)) + (< urx (- sizex boxw gapx boxw))))) ;; is there room for another column? (loop (car tal) (cdr tal) (if have-room (+ llx boxw gapx) xtorig) ;; have room, (if have-room lly (+ lly boxh gapy)) (if have-room (+ urx boxw gapx) (+ xtorig boxw)) @@ -592,11 +595,12 @@ (iup:vbox (iup:canvas #:action (make-canvas-action (lambda (cnv xadj yadj) ;; (print "cnv: " cnv " x: " x " y: " y) (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames))) - #:size "150x200" + #:size "150x150" + #:expand "YES" #:scrollbar "YES" #:posx "0.5" #:posy "0.5"))))))) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -22,10 +22,11 @@ (declare (uses common)) (declare (uses db)) (declare (uses tests)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. (declare (uses server)) +(declare (uses daemon)) (include "common_records.scm") (include "db_records.scm") (define (http-transport:make-server-url hostport) @@ -43,10 +44,22 @@ ;; Call this to start the actual server ;; (define *db:process-queue-mutex* (make-mutex)) +(define (server:get-best-guess-address hostname) + (let ((res #f)) + (for-each + (lambda (adr) + (if (not (eq? (u8vector-ref adr 0) 127)) + (set! res adr))) + (vector->list (hostinfo-addresses (hostname->hostinfo hostname)))) + (string-intersperse + (map number->string + (u8vector->list + (if res res (hostname->ip hostname)))) "."))) + (define (http-transport:run hostn) (debug:print 2 "Attempting to start the server ...") (if (not *toppath*) (if (not (setup-for-run)) (begin @@ -56,11 +69,12 @@ ;; #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))) ".") + ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") + (server:get-best-guess-address hostname) #f))) (if ipstr ipstr hostn))) ;; hostname))) (start-port (if (and (args:get-arg "-port") (string->number (args:get-arg "-port"))) (string->number (args:get-arg "-port")) @@ -118,11 +132,11 @@ exn (begin (print-error-message exn) (if (< portnum 9000) (begin - (print "WARNING: failed to start on portnum: " portnum ", trying next port") + (debug:print 0 "WARNING: failed to start on portnum: " portnum ", trying next port") (thread-sleep! 0.1) ;; (open-run-close tasks:remove-server-records tasks:open-db) (open-run-close tasks:server-delete tasks:open-db ipaddrstr portnum) (http-transport:try-start-server ipaddrstr (+ portnum 1))) (print "ERROR: Tried and tried but could not start the server"))) @@ -133,11 +147,12 @@ tasks:open-db (current-process-id) ipaddrstr portnum 0 'live 'http) (print "INFO: Trying to start server on " ipaddrstr ":" portnum) ;; This starts the spiffy server - (start-server port: portnum) + ;; NEED WAY TO SET IP TO #f TO BIND ALL + (start-server bind-address: ipaddrstr port: portnum) (open-run-close tasks:server-delete tasks:open-db ipaddrstr portnum) (print "INFO: server has been stopped"))) ;;====================================================================== ;; S E R V E R U T I L I T I E S @@ -312,10 +327,25 @@ (set! *didsomething* #t) (thread-join! th2)) (debug:print 0 "ERROR: Failed to setup for megatest"))) (exit))) +;; (use trace) +;; (trace http-transport:keep-running +;; tasks:get-best-server +;; http-transport:run +;; http-transport:launch +;; http-transport:try-start-server +;; http-transport:client-send-receive +;; http-transport:make-server-url +;; tasks:server-register +;; tasks:server-delete +;; start-server +;; hostname->ip +;; with-input-from-request +;; tasks:server-deregister-self) + (define (http-transport:server-signal-handler signum) (handle-exceptions exn (debug:print " ... exiting ...") (let ((th1 (make-thread (lambda () Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -23,10 +23,11 @@ (declare (uses launch)) (declare (uses server)) (declare (uses client)) (declare (uses tests)) (declare (uses genexample)) +(declare (uses daemon)) (define *db* #f) ;; this is only for the repl, do not use in general!!!! (include "common_records.scm") (include "key_records.scm") @@ -313,21 +314,29 @@ (hash-table-keys args:arg-hash) '("-runtests" "-list-runs" "-rollup" "-remove-runs" "-lock" "-unlock" "-update-meta" "-extract-ods")))) (if (setup-for-run) - (let ((servers (open-run-close tasks:get-best-server tasks:open-db))) + (let loop ((servers (open-run-close tasks:get-best-server tasks:open-db)) + (trycount 0)) (if (or (not servers) (null? servers)) (begin - (debug:print 0 "INFO: Starting server as none running ...") - ;; (server:launch (string->symbol (args:get-arg "-transport" "http")))) - (system (conc (car (argv)) " -server - -daemonize -transport " (args:get-arg "-transport" "http"))) - (thread-sleep! 3)) ;; give the server a few seconds to start - (debug:print 0 "INFO: Servers already running " servers) + (if (eq? trycount 0) ;; just do the server start once + (begin + (debug:print 0 "INFO: Starting server as none running ...") + ;; (server:launch (string->symbol (args:get-arg "-transport" "http")))) + ;; (process-run (car (argv)) (list "-server" "-" "-daemonize" "-transport" (args:get-arg "-transport" "http"))) + (process-fork (lambda () + (daemon:ize) + (server:launch (string->symbol (args:get-arg "-transport" "http"))))) + (thread-sleep! 3)) + (debug:print-info 0 "Waiting for server to start")) + (loop (open-run-close tasks:get-best-server tasks:open-db) + (+ trycount 1))) + (debug:print 0 "INFO: Server(s) running " servers) ))))) - (if (or (args:get-arg "-list-servers") (args:get-arg "-stop-server")) (let ((tl (setup-for-run))) (if tl @@ -370,12 +379,11 @@ (debug:print-info 0 "Attempting to stop server with pid " pid) (tasks:kill-server status hostname pullport pid transport))))) servers) (debug:print-info 1 "Done with listservers") (set! *didsomething* #t) - (exit) ;; must do, would have to add checks to many/all calls below - ) + (exit)) ;; must do, would have to add checks to many/all calls below (exit))) ;; if not list or kill then start a client (if appropriate) (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test") (eq? (length (hash-table-keys args:arg-hash)) 0)) (debug:print-info 1 "Server connection not needed") Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -254,83 +254,11 @@ ;; (sqlite3:finalize! db) ;; now add non-directly referenced dependencies (i.e. waiton) ;;====================================================================== ;; refactoring this block into tests:get-full-data ;;====================================================================== - (if (not (null? test-names)) - (let loop ((hed (car test-names)) - (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc - (debug:print-info 4 "hed=" hed " at top of loop") - (let* ((config (tests:get-testconfig hed 'return-procs)) - (waitons (let ((instr (if config - (config-lookup config "requirements" "waiton") - (begin ;; No config means this is a non-existant test - (debug:print 0 "ERROR: non-existent required test \"" hed "\"") - (if db (sqlite3:finalize! db)) - (exit 1))))) - (debug:print-info 8 "waitons string is " instr) - (string-split (cond - ((procedure? instr) - (let ((res (instr))) - (debug:print-info 8 "waiton procedure results in string " res " for test " hed) - res)) - ((string? instr) instr) - (else - ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " hed) - "")))))) - (debug:print-info 8 "waitons: " waitons) - ;; check for hed in waitons => this would be circular, remove it and issue an - ;; error - (if (member hed waitons) - (begin - (debug:print 0 "ERROR: test " hed " has listed itself as a waiton, please correct this!") - (set! waitons (filter (lambda (x)(not (equal? x hed))) waitons)))) - - ;; (items (items:get-items-from-config config))) - (if (not (hash-table-ref/default test-records hed #f)) - (hash-table-set! test-records - hed (vector hed ;; 0 - config ;; 1 - waitons ;; 2 - (config-lookup config "requirements" "priority") ;; priority 3 - (let ((items (hash-table-ref/default config "items" #f)) ;; items 4 - (itemstable (hash-table-ref/default config "itemstable" #f))) - ;; if either items or items table is a proc return it so test running - ;; process can know to call items:get-items-from-config - ;; if either is a list and none is a proc go ahead and call get-items - ;; otherwise return #f - this is not an iterated test - (cond - ((procedure? items) - (debug:print-info 4 "items is a procedure, will calc later") - items) ;; calc later - ((procedure? itemstable) - (debug:print-info 4 "itemstable is a procedure, will calc later") - itemstable) ;; calc later - ((filter (lambda (x) - (let ((val (car x))) - (if (procedure? val) val #f))) - (append (if (list? items) items '()) - (if (list? itemstable) itemstable '()))) - 'have-procedure) - ((or (list? items)(list? itemstable)) ;; calc now - (debug:print-info 4 "items and itemstable are lists, calc now\n" - " items: " items " itemstable: " itemstable) - (items:get-items-from-config config)) - (else #f))) ;; not iterated - #f ;; itemsdat 5 - #f ;; spare - used for item-path - ))) - (for-each - (lambda (waiton) - (if (and waiton (not (member waiton test-names))) - (begin - (set! required-tests (cons waiton required-tests)) - (set! test-names (cons waiton test-names))))) ;; was an append, now a cons - waitons) - (let ((remtests (delete-duplicates (append waitons tal)))) - (if (not (null? remtests)) - (loop (car remtests)(cdr remtests))))))) + (tests:get-full-data test-names test-records required-tests) (if (not (null? required-tests)) (debug:print-info 1 "Adding " required-tests " to the run queue")) ;; NOTE: these are all parent tests, items are not expanded yet. (debug:print-info 4 "test-records=" (hash-table->alist test-records)) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -539,13 +539,12 @@ (debug:print-info 4 "hed=" hed " at top of loop") (let* ((config (tests:get-testconfig hed 'return-procs)) (waitons (let ((instr (if config (config-lookup config "requirements" "waiton") (begin ;; No config means this is a non-existant test - (debug:print 0 "ERROR: non-existent required test \"" hed "\"") - (if db (sqlite3:finalize! db)) - (exit 1))))) + (debug:print 0 "ERROR: non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.") + "")))) (debug:print-info 8 "waitons string is " instr) (string-split (cond ((procedure? instr) (let ((res (instr))) (debug:print-info 8 "waiton procedure results in string " res " for test " hed) @@ -552,62 +551,68 @@ res)) ((string? instr) instr) (else ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " hed) "")))))) - (debug:print-info 8 "waitons: " waitons) - ;; check for hed in waitons => this would be circular, remove it and issue an - ;; error - (if (member hed waitons) - (begin - (debug:print 0 "ERROR: test " hed " has listed itself as a waiton, please correct this!") - (set! waitons (filter (lambda (x)(not (equal? x hed))) waitons)))) - - ;; (items (items:get-items-from-config config))) - (if (not (hash-table-ref/default test-records hed #f)) - (hash-table-set! test-records - hed (vector hed ;; 0 - config ;; 1 - waitons ;; 2 - (config-lookup config "requirements" "priority") ;; priority 3 - (let ((items (hash-table-ref/default config "items" #f)) ;; items 4 - (itemstable (hash-table-ref/default config "itemstable" #f))) - ;; if either items or items table is a proc return it so test running - ;; process can know to call items:get-items-from-config - ;; if either is a list and none is a proc go ahead and call get-items - ;; otherwise return #f - this is not an iterated test - (cond - ((procedure? items) - (debug:print-info 4 "items is a procedure, will calc later") - items) ;; calc later - ((procedure? itemstable) - (debug:print-info 4 "itemstable is a procedure, will calc later") - itemstable) ;; calc later - ((filter (lambda (x) - (let ((val (car x))) - (if (procedure? val) val #f))) - (append (if (list? items) items '()) - (if (list? itemstable) itemstable '()))) - 'have-procedure) - ((or (list? items)(list? itemstable)) ;; calc now - (debug:print-info 4 "items and itemstable are lists, calc now\n" - " items: " items " itemstable: " itemstable) - (items:get-items-from-config config)) - (else #f))) ;; not iterated - #f ;; itemsdat 5 - #f ;; spare - used for item-path - ))) - (for-each - (lambda (waiton) - (if (and waiton (not (member waiton test-names))) - (begin - (set! required-tests (cons waiton required-tests)) - (set! test-names (cons waiton test-names))))) ;; was an append, now a cons - waitons) - (let ((remtests (delete-duplicates (append waitons tal)))) - (if (not (null? remtests)) - (loop (car remtests)(cdr remtests)))))))) + (if (not config) ;; this is a non-existant test called in a waiton. + (if (null? tal) + test-records + (loop (car tal)(cdr tal))) + (begin + (debug:print-info 8 "waitons: " waitons) + ;; check for hed in waitons => this would be circular, remove it and issue an + ;; error + (if (member hed waitons) + (begin + (debug:print 0 "ERROR: test " hed " has listed itself as a waiton, please correct this!") + (set! waitons (filter (lambda (x)(not (equal? x hed))) waitons)))) + + ;; (items (items:get-items-from-config config))) + (if (not (hash-table-ref/default test-records hed #f)) + (hash-table-set! test-records + hed (vector hed ;; 0 + config ;; 1 + waitons ;; 2 + (config-lookup config "requirements" "priority") ;; priority 3 + (let ((items (hash-table-ref/default config "items" #f)) ;; items 4 + (itemstable (hash-table-ref/default config "itemstable" #f))) + ;; if either items or items table is a proc return it so test running + ;; process can know to call items:get-items-from-config + ;; if either is a list and none is a proc go ahead and call get-items + ;; otherwise return #f - this is not an iterated test + (cond + ((procedure? items) + (debug:print-info 4 "items is a procedure, will calc later") + items) ;; calc later + ((procedure? itemstable) + (debug:print-info 4 "itemstable is a procedure, will calc later") + itemstable) ;; calc later + ((filter (lambda (x) + (let ((val (car x))) + (if (procedure? val) val #f))) + (append (if (list? items) items '()) + (if (list? itemstable) itemstable '()))) + 'have-procedure) + ((or (list? items)(list? itemstable)) ;; calc now + (debug:print-info 4 "items and itemstable are lists, calc now\n" + " items: " items " itemstable: " itemstable) + (items:get-items-from-config config)) + (else #f))) ;; not iterated + #f ;; itemsdat 5 + #f ;; spare - used for item-path + ))) + (for-each + (lambda (waiton) + (if (and waiton (not (member waiton test-names))) + (begin + (set! required-tests (cons waiton required-tests)) + (set! test-names (cons waiton test-names))))) ;; was an append, now a cons + waitons) + (let ((remtests (delete-duplicates (append waitons tal)))) + (if (not (null? remtests)) + (loop (car remtests)(cdr remtests)) + test-records)))))))) ;;====================================================================== ;; test steps ;;======================================================================