1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
|
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
+
+
+
+
|
(if pktsdir
(with-output-to-file
(conc pktsdir "/" uuid ".pkt")
(lambda ()
(print pkt)))
(print "ERROR: cannot process commands without a pkts directory")))
(define (check-if-modepatt-defined pkta notification-hook pktfile)
(let* ((start-dir (alist-ref 'S pkta))
(target (or (alist-ref 'R pkta) (alist-ref 't pkta)))
(patt (alist-ref 'o pkta))
(uuid (alist-ref 'Z pkta))
(cmd (conc "megatest -show-runconfig -target " target " -start-dir " start-dir))
(res (handle-exceptions
exn
#f
(print "Running " cmd)
(with-input-from-pipe cmd read-lines))))
(let loop ((hed (car res))
(tail (cdr res)))
(if (string-contains hed patt)
#t
(if (null? tail)
(begin
(if notification-hook
(let* ((notification-cmd (conc notification-hook " --pkt " pktfile " --msg INVALID_MODEPATT")))
(print "Running " notification-cmd)
(system notification-cmd)))
#f)
(loop (car tail) (cdr tail)))))))
(define (check-if-target-defined pkta notification-hook pktfile)
(let* ((start-dir (alist-ref 'S pkta))
(target (alist-ref 'R pkta))
(uuid (alist-ref 'Z pkta))
(cmd (conc "megatest -list-targets -start-dir " start-dir))
(res (handle-exceptions
exn
#f
(print "Running " cmd)
(with-input-from-pipe cmd read-lines))))
(if (member target res)
#t
(begin
(if notification-hook
(let* ((notification-cmd (conc notification-hook " --pkt " pktfile " --msg INVALID_TARGET")))
(print "Running " notification-cmd)
(system notification-cmd)))
#f))))
(define (validate-cmd cmd pkta notification-hook pktfile)
(let ((ret #t))
(if (string-contains cmd "-reqtarg")
(if (check-if-target-defined pkta notification-hook pktfile)
(begin
(print "Target is valid")
(if (string-contains cmd "-modepatt")
(if (check-if-modepatt-defined pkta notification-hook pktfile)
(print "Modepatt is valid")
(set! ret #f))))
(set! ret #f))
(if (string-contains cmd "-modepatt")
(if (check-if-modepatt-defined pkta notification-hook pktfile)
(print "Modepatt is valid")
(set! ret #f))))
ret))
;; collect all needed data and create run pkts for contours with changed inputs
;;
(define (dispatch-commands mtconf toppath)
;; we are expecting a directory "logs", check and create it, create the log in /tmp if not able to create logs dir
(let ((logdir
(if (if (not (directory? "logs"))
(handle-exceptions
exn
#f
(create-directory "logs")
#t)
exn
#f
(create-directory "logs")
#t)
#t)
"logs"
"/tmp"))
(cpuload (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f)))
(maxload (string->number (or (configf:lookup mtconf "setup" "maxload")
(configf:lookup mtconf "jobtools" "maxload") ;; respect value used by Megatest calls
"1.1"))))
"1.1")))
(notification-hook (if (configf:lookup mtconf "setup" "notification-hook")
(configf:lookup mtconf "setup" "notification-hook")
#f)))
(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) '()))
(torun (make-hash-table)) ;; target => ( ... info ... )
(rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering
(for-each
(lambda (pktdat)
(let* ((pkta (alist-ref 'apkt pktdat))
(action (alist-ref 'A pkta))
(cmdline (pkt->cmdline pkta))
(uuid (alist-ref 'Z pkta))
(user (alist-ref 'U pkta))
(area (alist-ref 'G pkta))
(logf (conc logdir "/" uuid "-run.log"))
(pktfile (conc pktsdir "/" uuid ".pkt"))
(fullcmd (conc "NBFAKE_LOG=" logf " nbfake " cmdline)))
(if (check-access user mtconf action area)
(if (and (> cpuload maxload)
(member action '("run" "archive"))) ;; do not run archive or run if load is over the specified limit
(begin
(print "WARNING: cpuload too high, skipping processing of " uuid " due to " cpuload " > " maxload)
(print "WARNING: cpuload too high, skipping processing of " uuid " due to " cpuload " > " maxload)
(if notification-hook
(let* ((notification-cmd (conc notification-hook " --pkt " pktfile " --msg HIGH_LOAD")))
(print "Running " notification-cmd)
(system notification-cmd))))
(begin
;; if modepatt used chek if it is defined for the target. If -reqtarg check if target exist.
(if (validate-cmd fullcmd pkta notification-hook pktfile)
(begin
(print "RUNNING: " fullcmd)
(system fullcmd) ;; replace with process ...
(mark-processed pdb (list (alist-ref 'id pktdat)))
(let-values (((ack-uuid ack-pkt)
(add-z-card
(construct-sdat 'P uuid
'T (case (string->symbol action)
((run) "runstart")
((sync) "syncstart") ;; example of translating run -> runstart
(else action))
'G (alist-ref 'G pkta)
'c (alist-ref 'c pkta) ;; THIS IS WRONG! SHOULD BE 'c
't (alist-ref 't pkta)))))
(write-pkt pktsdir ack-uuid ack-pkt))))
(print "RUNNING: " fullcmd)
(system fullcmd) ;; replace with process ...
(mark-processed pdb (list (alist-ref 'id pktdat)))
(let-values (((ack-uuid ack-pkt)
(add-z-card
(construct-sdat 'P uuid
'T (case (string->symbol action)
((run) "runstart")
((sync) "syncstart") ;; example of translating run -> runstart
(else action))
'G (alist-ref 'G pkta)
'c (alist-ref 'c pkta) ;; THIS IS WRONG! SHOULD BE 'c
't (alist-ref 't pkta)))))
(write-pkt pktsdir ack-uuid ack-pkt))
(if notification-hook
(let* ((notification-cmd (conc notification-hook " --pkt " pktfile " --msg RUN_LAUNCHED --contour " (caar contours) " --log_path " logf )))
(print "Running " notification-cmd)
(system notification-cmd))))
(begin
(mark-processed pdb (list (alist-ref 'id pktdat)))
(let-values (((ack-uuid ack-pkt)
(add-z-card
(construct-sdat 'P uuid
'T "invalid-input"
'c (alist-ref 'o pkta) ;; THIS IS WRONG! SHOULD BE 'c
't (alist-ref 't pkta)))))
(write-pkt pktsdir ack-uuid ack-pkt))))))
(begin ;; access denied! Mark as such
(mark-processed pdb (list (alist-ref 'id pktdat)))
(let-values (((ack-uuid ack-pkt)
(add-z-card
(construct-sdat 'P uuid
'T "access-denied"
'c (alist-ref 'o pkta) ;; THIS IS WRONG! SHOULD BE 'c
't (alist-ref 't pkta)))))
(write-pkt pktsdir ack-uuid ack-pkt))))))
(write-pkt pktsdir ack-uuid ack-pkt))
(if notification-hook
(let* ((notification-cmd (conc notification-hook " --pkt " pktfile " --msg ACCESS_DENIED")))
(print "Running " notification-cmd)
(system notification-cmd)))))))
pkts))))))
(define (check-access user mtconf action area)
;; NOTE: Need control over defaults. E.g. default might be no access
(let* ((access-ctrl (hash-table-exists? mtconf "access")) ;; if there is an access section the default is to REQUIRE enablement/access
(access-list (map (lambda (x)
|