Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -8,11 +8,11 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== (use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo md5 message-digest typed-records directory-utils stack - matchable) + matchable pkts (prefix dbi dbi:)) (require-extension regex posix) (require-extension (srfi 18) extras tcp rpc) (import (prefix sqlite3 sqlite3:)) @@ -2313,6 +2313,71 @@ (read-config mthome-cfgfile view-cfgdat #t)) ;; we load the home dir file AFTER the MTRAH file so the user can clobber settings when running the dashboard in read-only areas (if (file-exists? home-cfgfile) (read-config home-cfgfile view-cfgdat #t)) view-cfgdat)) + +;;====================================================================== +;; Manage pkts, used in servers, tests and likely other contexts so put +;; in common +;;====================================================================== + +(define (common:with-queue-db mtconf proc) + (let* ((pktsdirs (configf:lookup mtconf "setup" "pktsdirs")) + (pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f)) + (toppath (configf:lookup mtconf "dyndat" "toppath")) + (pdbpath (or (configf:lookup mtconf "setup" "pdbpath") pktsdir))) + (if (not (and pktsdir toppath pdbpath)) + (begin + (print "ERROR: settings are missing in your megatest.config for area management.") + (print " you need to have pktsdir in the [setup] section.")) + (let* ((pdb (open-queue-db pdbpath "pkts.db" + schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));")))) + (proc pktsdirs pktsdir pdb) + (dbi:close pdb))))) + +(define (common:load-pkts-to-db mtconf) + (common:with-queue-db + mtconf + (lambda (pktsdirs pktsdir pdb) + (for-each + (lambda (pktsdir) ;; look at all + (if (and (file-exists? pktsdir) + (directory? pktsdir) + (file-read-access? pktsdir)) + (let ((pkts (glob (conc pktsdir "/*.pkt")))) + (for-each + (lambda (pkt) + (let* ((uuid (cadr (string-match ".*/([0-9a-f]+).pkt" pkt))) + (exists (lookup-by-uuid pdb uuid #f))) + (if (not exists) + (let* ((pktdat (string-intersperse + (with-input-from-file pkt read-lines) + "\n")) + (apkt (pkt->alist pktdat)) + (ptype (alist-ref 'T apkt))) + (add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0) + (debug:print 4 *default-log-port* "Added " uuid " of type " ptype " to queue")) + (debug:print 4 *default-log-port* "pkt: " uuid " exists, skipping...") + ))) + pkts)))) + (string-split pktsdirs))))) + +(define (common:get-pkt-alists pkts) + (map (lambda (x) + (alist-ref 'apkt x)) ;; 'pkta pulls out the alist from the read pkt + pkts)) + +;; given list of pkts (alist mode) return list of D cards as Unix epoch, sorted descending +;; also delete duplicates by target i.e. (car pkt) +;; +(define (common:get-pkt-times pkts) + (delete-duplicates + (sort + (map (lambda (x) + `(,(alist-ref 't x) . ,(string->number (alist-ref 'D x)))) + pkts) + (lambda (a b)(> (cdr a)(cdr b)))) ;; sort descending + (lambda (a b)(equal? (car a)(car b))))) ;; remove duplicates by target + + Index: megatest.config ================================================================== --- megatest.config +++ megatest.config @@ -1,9 +1,9 @@ -[fields] -a text -b text -c text +# [fields] +# a text +# b text +# c text [setup] pktsdirs /tmp/pkts /some/other/source [areas] Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -12,11 +12,11 @@ ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) (use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras) - srfi-18 extras format pkts pkts regex regex-case + srfi-18 extras format pkts regex regex-case (prefix dbi dbi:)) ;; zmq extras) (declare (uses common)) (declare (uses megatest-version)) (declare (uses margs)) @@ -311,67 +311,10 @@ ;;====================================================================== ;; pkts ;;====================================================================== -(define (with-queue-db mtconf proc) - (let* ((pktsdirs (configf:lookup mtconf "setup" "pktsdirs")) - (pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f)) - (toppath (configf:lookup mtconf "dyndat" "toppath")) - (pdbpath (or (configf:lookup mtconf "setup" "pdbpath") pktsdir))) - (if (not (and pktsdir toppath pdbpath)) - (begin - (print "ERROR: settings are missing in your megatest.config for area management.") - (print " you need to have pktsdir in the [setup] section.")) - (let* ((pdb (open-queue-db pdbpath "pkts.db" - schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));")))) - (proc pktsdirs pktsdir pdb) - (dbi:close pdb))))) - -(define (load-pkts-to-db mtconf) - (with-queue-db - mtconf - (lambda (pktsdirs pktsdir pdb) - (for-each - (lambda (pktsdir) ;; look at all - (if (and (file-exists? pktsdir) - (directory? pktsdir) - (file-read-access? pktsdir)) - (let ((pkts (glob (conc pktsdir "/*.pkt")))) - (for-each - (lambda (pkt) - (let* ((uuid (cadr (string-match ".*/([0-9a-f]+).pkt" pkt))) - (exists (lookup-by-uuid pdb uuid #f))) - (if (not exists) - (let* ((pktdat (string-intersperse - (with-input-from-file pkt read-lines) - "\n")) - (apkt (pkt->alist pktdat)) - (ptype (alist-ref 'T apkt))) - (add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0) - (debug:print 4 *default-log-port* "Added " uuid " of type " ptype " to queue")) - (debug:print 4 *default-log-port* "pkt: " uuid " exists, skipping...") - ))) - pkts)))) - (string-split pktsdirs))))) - -(define (get-pkt-alists pkts) - (map (lambda (x) - (alist-ref 'apkt x)) ;; 'pkta pulls out the alist from the read pkt - pkts)) - -;; given list of pkts (alist mode) return list of D cards as Unix epoch, sorted descending -;; also delete duplicates by target i.e. (car pkt) -(define (get-pkt-times pkts) - (delete-duplicates - (sort - (map (lambda (x) - `(,(alist-ref 't x) . ,(string->number (alist-ref 'D x)))) - pkts) - (lambda (a b)(> (cdr a)(cdr b)))) ;; sort descending - (lambda (a b)(equal? (car a)(car b))))) ;; remove duplicates by target - ;;====================================================================== ;; Runs ;;====================================================================== ;; make a runname @@ -538,11 +481,11 @@ ;; collect all needed data and create run pkts for contours with changed inputs ;; (define (generate-run-pkts mtconf toppath) (let ((std-runname (conc "sched" (time->string (seconds->local-time (current-seconds)) "%M%H%d")))) - (with-queue-db + (common:with-queue-db mtconf (lambda (pktsdirs pktsdir pdb) (let* ((rgconfdat (find-and-read-config (conc toppath "/runconfigs.config"))) (rgconf (car rgconfdat)) (all-areas (map car (configf:get-section mtconf "areas"))) @@ -570,20 +513,20 @@ (runname (make-runname "" "")) (runtrans (alist-ref 'runtrans val-alist)) (runstarts (find-pkts pdb '(runstart) `((o . ,contour) (t . ,runkey)))) - (rspkts (get-pkt-alists runstarts)) + (rspkts (common:get-pkt-alists runstarts)) ;; starttimes is for run start times and is used to know when the last run was launched - (starttimes (get-pkt-times rspkts)) ;; sort by age (youngest first) and delete duplicates by target + (starttimes (common:get-pkt-times rspkts)) ;; sort by age (youngest first) and delete duplicates by target (last-run (if (null? starttimes) ;; if '() then it has never been run, else get the max 0 (apply max (map cdr starttimes)))) ;; synctimes is for figuring out the last time a sync was done (syncstarts (find-pkts pdb '(syncstart) '())) ;; no qualifiers, a sync does all tarets etc. - (sspkts (get-pkt-alists syncstarts)) - (synctimes (get-pkt-times sspkts)) + (sspkts (common:get-pkt-alists syncstarts)) + (synctimes (common:get-pkt-times sspkts)) (last-sync (if (null? synctimes) ;; if '() then it has never been run, else get the max 0 (apply max (map cdr synctimes)))) ) @@ -866,11 +809,11 @@ (create-directory "logs") #t) #t) "logs" "/tmp"))) - (with-queue-db + (common:with-queue-db mtconf (lambda (pktsdirs pktsdir pdb) (let* ((rgconfdat (find-and-read-config (conc toppath "/runconfigs.config"))) (rgconf (car rgconfdat)) (areas (configf:get-section mtconf "areas")) @@ -930,15 +873,15 @@ (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir"))) (mtconf (car mtconfdat)) (toppath (configf:lookup mtconf "dyndat" "toppath"))) (case (string->symbol *action*) ((process) (begin - (load-pkts-to-db mtconf) + (common:load-pkts-to-db mtconf) (generate-run-pkts mtconf toppath) - (load-pkts-to-db mtconf) + (common:load-pkts-to-db mtconf) (dispatch-commands mtconf toppath))) - ((import) (load-pkts-to-db mtconf)) ;; import pkts + ((import) (common:load-pkts-to-db mtconf)) ;; import pkts ((rungen) (generate-run-pkts mtconf toppath)) ((dispatch) (dispatch-commands mtconf toppath))))) ((db) (if (null? remargs) (print "ERROR: missing sub command for db command") Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -8,12 +8,13 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. (require-extension (srfi 18) extras tcp s11n) -(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest directory-utils posix-extras matchable) -;; (use zmq) +(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest directory-utils posix-extras matchable + pkts + ) (use spiffy uri-common intarweb http-client spiffy-request-vars) (declare (unit server)) Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -47,11 +47,13 @@ waivercommentpatt ^WW\d+ [a-z].* incomplete-timeout 1 # wait 0.5 seconds between launching every process # -launch-delay 0.5 +# launch-delay 0.5 +launch-delay 0 + # wait for runs to completely complete. yes, anything else is no run-wait yes # If set to "default" the old code is used. Otherwise defaults to 200 or uses