Overview
Comment: | File sensing now working |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | run-mgr |
Files: | files | file ages | folders |
SHA1: |
a83fac111f346951a75ede6ed0e05645 |
User & Date: | matt on 2017-02-13 22:04:03 |
Other Links: | branch diff | manifest | tags |
Context
2017-02-13
| ||
22:48 | Fixed few problems with actual launching of runs. check-in: 7d33809fbf user: matt tags: run-mgr | |
22:04 | File sensing now working check-in: a83fac111f user: matt tags: run-mgr | |
2017-02-12
| ||
22:50 | Dispatching works. All pieces in place to implement change checks check-in: da6405a876 user: matt tags: run-mgr | |
Changes
Modified common.scm from [073513eab3] to [a19079c68b].
1 2 3 4 5 6 7 8 9 10 11 | ;;====================================================================== ;; 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. ;;====================================================================== | | > | 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) (require-extension regex posix) (require-extension (srfi 18) extras tcp rpc) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) |
︙ | ︙ | |||
788 789 790 791 792 793 794 | (create-directory hed #t))))) (if (and (string? res) (directory? res)) res (if (null? tal) #f (loop (car tal)(cdr tal)))))))) | | > > > > > > > > > > > > > > > > > > > > > > | 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 | (create-directory hed #t))))) (if (and (string? res) (directory? res)) res (if (null? tal) #f (loop (car tal)(cdr tal)))))))) ;; return the youngest timestamp . filename ;; (define (common:get-youngest glob-list) (let ((all-files (apply append (map (lambda (patt) (handle-exceptions exn '() (glob patt))) glob-list)))) (fold (lambda (fname res) (let ((last-mod (car res)) (curmod (handle-exceptions exn 0 (file-modification-time fname)))) (if (> curmod last-mod) (list curmod fname) res))) '(0 "n/a") all-files))) ;;====================================================================== ;; T A R G E T S , S T A T E , S T A T U S , ;; R U N N A M E A N D T E S T P A T T ;;====================================================================== ;; (map print (map car (hash-table->alist (read-config "runconfigs.config" #f #t)))) ;; |
︙ | ︙ |
Modified mtut.scm from [f71da7508c] to [e2f38ea970].
︙ | ︙ | |||
122 123 124 125 126 127 128 129 130 131 132 133 134 135 | ("-contour" . c) ("-test-patt" . p) ;; idea, enhance margs ("-test-patt" "-testpatt") => yields one value in "-test-patt" ("-mode-patt" . o) ("-tag-expr" . x) ("-item-patt" . i) ;; misc ("-start-dir" . S) ("-set-vars" . v) ("-debug" . #f) ;; for *verbosity* > 2 ("-load" . #f) ;; load and exectute a scheme file ("-log" . #f) )) (define *switch-keys* '(("-h" . #f) | > | 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 | ("-contour" . c) ("-test-patt" . p) ;; idea, enhance margs ("-test-patt" "-testpatt") => yields one value in "-test-patt" ("-mode-patt" . o) ("-tag-expr" . x) ("-item-patt" . i) ;; misc ("-start-dir" . S) ("-msg" . M) ("-set-vars" . v) ("-debug" . #f) ;; for *verbosity* > 2 ("-load" . #f) ;; load and exectute a scheme file ("-log" . #f) )) (define *switch-keys* '(("-h" . #f) |
︙ | ︙ | |||
153 154 155 156 157 158 159 | ;; given a mtutil param, return the old megatest equivalent ;; (define (param-translate param) (or (alist-ref (string->symbol param) '((-tag-expr . "-tagexpr") (-mode-patt . "--modepatt") (-run-name . "-runname") | | > | 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 | ;; given a mtutil param, return the old megatest equivalent ;; (define (param-translate param) (or (alist-ref (string->symbol param) '((-tag-expr . "-tagexpr") (-mode-patt . "--modepatt") (-run-name . "-runname") (-test-patt . "-testpatt") (-msg . "-m"))) param)) ;; Card types: ;; ;; a action ;; u username (Unix) ;; D timestamp |
︙ | ︙ | |||
290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 | (mtconf (if mtconfdat (car mtconfdat) #f))) ;; we set some dynamic data in a section called "dyndata" (if mtconf (begin (configf:section-var-set! mtconf "dyndat" "toppath" start-dir))) (print "TOPPATH: " (configf:lookup mtconf "dyndat" "toppath")) mtconfdat)) ;; collect all needed data and create run pkts for contours with changed inputs ;; (define (generate-run-pkts mtconf toppath) (with-queue-db mtconf (lambda (pktsdirs pktsdir pdb) (let* ((rgconfdat (find-and-read-config (conc toppath "/rungen.config"))) (rgconf (car rgconfdat)) (areas (map car (configf:get-section mtconf "areas"))) (contours (configf:get-section mtconf "contours")) (torun (make-hash-table)) ;; target => ( ... info ... ) (rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering (for-each (lambda (runkey) | > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | < < < | | | | | > > > | | | | | < | | | | < < | > > | < | > | | < < < < < < < < < | < | < < > > | < < | < < < < < | > > > > > > > > > > > > > > > > > > > > > | 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 | (mtconf (if mtconfdat (car mtconfdat) #f))) ;; we set some dynamic data in a section called "dyndata" (if mtconf (begin (configf:section-var-set! mtconf "dyndat" "toppath" start-dir))) (print "TOPPATH: " (configf:lookup mtconf "dyndat" "toppath")) mtconfdat)) ;; make a run request pkt from basic data ;; (define (create-run-pkt mtconf area runkey runname mode-patt tag-expr pktsdir reason) (let ((area-path (configf:lookup mtconf "areas" area))) (let-values (((uuid pkt) (command-line->pkt "run" (append `(("-target" . ,runkey) ("-run-name" . ,runname) ("-start-dir" . ,area-path) ("-msg" . ,reason)) (if mode-patt `(("-mode-patt" . ,mode-patt)) '()) (if tag-expr `(("-tag-expr" . ,tag-expr)) '()) (if (not (or mode-patt tag-expr)) `(("-item-patt" . "%")) '()))))) (with-output-to-file (conc pktsdir "/" uuid ".pkt") (lambda () (print pkt)))))) ;; collect all needed data and create run pkts for contours with changed inputs ;; (define (generate-run-pkts mtconf toppath) (with-queue-db mtconf (lambda (pktsdirs pktsdir pdb) (let* ((rgconfdat (find-and-read-config (conc toppath "/rungen.config"))) (rgconf (car rgconfdat)) (areas (map car (configf:get-section mtconf "areas"))) (contours (configf:get-section mtconf "contours")) (torun (make-hash-table)) ;; target => ( ... info ... ) (rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering (for-each (lambda (runkey) (let* ((keydats (configf:get-section rgconf runkey))) (for-each (lambda (sense) ;; these are the sense rules (let* ((key (car sense)) (val (cadr sense)) (keyparts (string-split key ":")) (contour (car keyparts)) (ruletype (let ((res (cdr keyparts))) (if (null? res) #f (cadr keyparts)))) (valparts (string-split val)) ;; runname-rule params (runname (make-runname #f)) (runstarts (find-pkts pdb '(runstart) `((o . ,contour) (t . ,runkey)))) (rspkts (map (lambda (x) (alist-ref 'pkta x)) runstarts)) (starttimes ;; sort by age (youngest first) and delete duplicates by target (delete-duplicates (sort (map (lambda (x) `(,(alist-ref 't x) . ,(string->number (alist-ref 'D x)))) rspkts) (lambda (a b)(> (cdr a)(cdr b)))) ;; sort descending (lambda (a b)(equal? (car a)(car b))))) ;; remove duplicates by target ) ;; look in runstarts for matching runs by target and contour ;; get the timestamp for when that run started and pass it ;; to the rule logic here where "ruletype" will be applied ;; if it comes back "changed" then proceed to register the runs (case (string->symbol ruletype) ((file) (let* ((file-globs (cdr valparts)) (youngestdat (common:get-youngest file-globs)) (youngestmod (car youngestdat))) ;; (print "youngestmod: " youngestmod " starttimes: " starttimes) (if (null? starttimes) ;; this target has never been run (configf:section-var-set! torun contour runkey `("file:neverrun" ,runname)) (for-each (lambda (starttime) ;; look at the time the last run was kicked off for this contour (if (> youngestmod (cdr starttime)) (begin (print "starttime younger than youngestmod: " starttime " Youngestmod: " youngestmod) (configf:section-var-set! torun contour runkey `(,(conc ruletype ":" (cadr youngestdat)) ,runname))))) starttimes)) ))))) keydats))) (hash-table-keys rgconf)) ;; now have torun populated (for-each (lambda (contour) (let* ((mode-tag (string-split (or (configf:lookup mtconf "contours" contour) "") "/")) (mode-patt (if (eq? (length mode-tag) 2)(cadr mode-tag) #f)) (tag-expr (if (null? mode-tag) #f (car mode-tag)))) (for-each (lambda (runkeydat) (let* ((runkey (car runkeydat)) (info (cadr runkeydat))) (for-each (lambda (area) (let ((runname (cadr info)) (reason (car info))) (print "runkey: " runkey " contour: " contour " info: " info " area: " area " tag-expr: " tag-expr " mode-patt: " mode-patt) (create-run-pkt mtconf area runkey runname mode-patt tag-expr pktsdir reason))) areas))) (configf:get-section torun contour)))) (hash-table-keys torun)))))) (define (pkt->cmdline pkta) (fold (lambda (a res) (let* ((key (car a)) ;; get the key name (val (cdr a)) (par (lookup-param-by-key key))) ;; (print "key: " key " val: " val " par: " par) |
︙ | ︙ |