305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
|
;; NEED TIMESTAMP ON PKTS for efficient loading of packets into db.
;; 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))
|
|
|
>
|
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
|
;; NEED TIMESTAMP ON PKTS for efficient loading of packets into db.
;; make a run request pkt from basic data
;;
(define (create-run-pkt mtconf area runkey runname mode-patt tag-expr pktsdir reason contour)
(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)
("-contour" . ,contour))
(if mode-patt
`(("-mode-patt" . ,mode-patt))
'())
(if tag-expr
`(("-tag-expr" . ,tag-expr))
'())
(if (not (or mode-patt tag-expr))
|
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
|
keydats)))
(hash-table-keys rgconf))
;; now have torun populated
(for-each
(lambda (contour)
(let* ((mode-tag (string-split (or (configf:lookup mtconf "contours" contour) "") "/"))
(tag-expr (if (eq? (length mode-tag) 2)(cadr mode-tag) #f))
(mode-patt (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)
|
|
|
|
|
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
|
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 contour)))
areas)))
(configf:get-section torun contour))))
(hash-table-keys torun))))))
(define (pkt->cmdline pkta)
(fold (lambda (a res)
|
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
|
;; (lambda (key)
;; (if (not (member key *legal-params*))
;; (hash-table-delete! adjargs key))) ;; we need to delete any params intended for mtutil
;; (hash-table-keys adjargs))
(let-values (((uuid pkt)
(command-line->pkt *action* adjargs)))
(write-pkt pktsdir uuid pkt))))
((dispatch import rungen)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(toppath (configf:lookup mtconf "dyndat" "toppath")))
(case (string->symbol *action*)
((import) (load-pkts-to-db mtconf)) ;; import pkts
((rungen) (generate-run-pkts mtconf toppath))
((dispatch) (dispatch-commands mtconf toppath)))))))
(if (or (args:get-arg "-repl")
(args:get-arg "-load"))
(begin
|
|
>
>
>
>
>
|
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
|
;; (lambda (key)
;; (if (not (member key *legal-params*))
;; (hash-table-delete! adjargs key))) ;; we need to delete any params intended for mtutil
;; (hash-table-keys adjargs))
(let-values (((uuid pkt)
(command-line->pkt *action* adjargs)))
(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
(load-pkts-to-db mtconf)
(generate-run-pkts mtconf toppath)
(load-pkts-to-db mtconf)
(dispatch-commands mtconf toppath)))
((import) (load-pkts-to-db mtconf)) ;; import pkts
((rungen) (generate-run-pkts mtconf toppath))
((dispatch) (dispatch-commands mtconf toppath)))))))
(if (or (args:get-arg "-repl")
(args:get-arg "-load"))
(begin
|