Overview
Comment: | Moved basic pkt handling calls to common.scm so they can be used in server and test management |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.64-use-pkts |
Files: | files | file ages | folders |
SHA1: |
c1467629d6fe447d65bd5680cb958496 |
User & Date: | matt on 2017-05-14 23:16:37 |
Other Links: | branch diff | manifest | tags |
Context
2017-05-14
| ||
23:43 | More josling around stuff for pkts usage... check-in: e71001dca1 user: matt tags: v1.64-use-pkts | |
23:16 | Moved basic pkt handling calls to common.scm so they can be used in server and test management check-in: c1467629d6 user: matt tags: v1.64-use-pkts | |
2017-05-12
| ||
17:49 | bump version check-in: 554fc3a386 user: bjbarcla tags: v1.64, v1.6413 | |
Changes
Modified common.scm from [542229ad38] to [e727d58ecf].
1 2 3 4 5 6 7 8 9 10 11 12 | ;;====================================================================== ;; 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 srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo md5 message-digest typed-records directory-utils stack | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | ;;====================================================================== ;; 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 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 pkts (prefix dbi dbi:)) (require-extension regex posix) (require-extension (srfi 18) extras tcp rpc) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) |
︙ | ︙ | |||
2311 2312 2313 2314 2315 2316 2317 2318 | (mthome-cfgfile (conc *toppath* "/.mtviews.config"))) (if (file-exists? mthome-cfgfile) (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)) | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 | (mthome-cfgfile (conc *toppath* "/.mtviews.config"))) (if (file-exists? mthome-cfgfile) (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 |
Modified megatest.config from [ec85813c67] to [ef591e666d].
|
| | | | | | 1 2 3 4 5 6 7 8 9 10 11 | # [fields] # a text # b text # c text [setup] pktsdirs /tmp/pkts /some/other/source [areas] # path-to-area map-target-script(future, optional) fullrun path=tests/fullrun |
︙ | ︙ |
Modified mtut.scm from [b02905e71e] to [a30f91149b].
︙ | ︙ | |||
10 11 12 13 14 15 16 | ;; (include "common.scm") ;; (include "megatest-version.scm") ;; 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) | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | ;; (include "common.scm") ;; (include "megatest-version.scm") ;; 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 regex regex-case (prefix dbi dbi:)) ;; zmq extras) (declare (uses common)) (declare (uses megatest-version)) (declare (uses margs)) (declare (uses configf)) ;; (declare (uses rmt)) |
︙ | ︙ | |||
309 310 311 312 313 314 315 | (print help) (exit 1))) ;;====================================================================== ;; pkts ;;====================================================================== | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 309 310 311 312 313 314 315 316 317 318 319 320 321 322 | (print help) (exit 1))) ;;====================================================================== ;; pkts ;;====================================================================== ;;====================================================================== ;; Runs ;;====================================================================== ;; make a runname ;; (define (make-runname pre post) |
︙ | ︙ | |||
536 537 538 539 540 541 542 | ;; (use trace)(trace create-run-pkt) ;; 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")))) | | | 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 | ;; (use trace)(trace create-run-pkt) ;; 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")))) (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"))) (contours (configf:get-section mtconf "contours")) (torun (make-hash-table)) ;; target => ( ... info ... ) |
︙ | ︙ | |||
568 569 570 571 572 573 574 | ;; (val-list (string-split-fields ";\\s*" val #:infix)) ;; (string-split val)) ;; runname-rule params (val-alist (val->alist val)) (runname (make-runname "" "")) (runtrans (alist-ref 'runtrans val-alist)) (runstarts (find-pkts pdb '(runstart) `((o . ,contour) (t . ,runkey)))) | | | | | | 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 | ;; (val-list (string-split-fields ";\\s*" val #:infix)) ;; (string-split val)) ;; runname-rule params (val-alist (val->alist val)) (runname (make-runname "" "")) (runtrans (alist-ref 'runtrans val-alist)) (runstarts (find-pkts pdb '(runstart) `((o . ,contour) (t . ,runkey)))) (rspkts (common:get-pkt-alists runstarts)) ;; starttimes is for run start times and is used to know when the last run was launched (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 (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)))) ) (let ((delta (lambda (x) (round (/ (- (current-seconds) x) 60))))) |
︙ | ︙ | |||
864 865 866 867 868 869 870 | exn #f (create-directory "logs") #t) #t) "logs" "/tmp"))) | | | 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 | exn #f (create-directory "logs") #t) #t) "logs" "/tmp"))) (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")) (contours (configf:get-section mtconf "contours")) (pkts (find-pkts pdb '(cmd) '())) |
︙ | ︙ | |||
928 929 930 931 932 933 934 | (write-pkt pktsdir uuid pkt)))) ((dispatch import rungen process) (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir"))) (mtconf (car mtconfdat)) (toppath (configf:lookup mtconf "dyndat" "toppath"))) (case (string->symbol *action*) ((process) (begin | | | | | 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 | (write-pkt pktsdir uuid pkt)))) ((dispatch import rungen process) (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir"))) (mtconf (car mtconfdat)) (toppath (configf:lookup mtconf "dyndat" "toppath"))) (case (string->symbol *action*) ((process) (begin (common:load-pkts-to-db mtconf) (generate-run-pkts mtconf toppath) (common:load-pkts-to-db mtconf) (dispatch-commands mtconf toppath))) ((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") (let ((subcmd (car remargs))) (case (string->symbol subcmd) |
︙ | ︙ |
Modified server.scm from [32389a7830] to [3ff46c3d7b].
1 2 3 4 5 6 7 8 9 10 11 12 | ;; 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) | | < > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | ;; 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 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)) (declare (uses common)) (declare (uses db)) |
︙ | ︙ |
Modified tests/fullrun/megatest.config from [55e292f1b8] to [a290fb1cb4].
︙ | ︙ | |||
45 46 47 48 49 50 51 | # this may save a few milliseconds on launching tests # launchwait no waivercommentpatt ^WW\d+ [a-z].* incomplete-timeout 1 # wait 0.5 seconds between launching every process # | | > > | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 | # this may save a few milliseconds on launching tests # launchwait no waivercommentpatt ^WW\d+ [a-z].* incomplete-timeout 1 # wait 0.5 seconds between launching every process # # 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 # numeric value given. # |
︙ | ︙ |